pax_global_header00006660000000000000000000000064126037755640014531gustar00rootroot0000000000000052 comment=892c40c9f9c93121cddbef6be7f1081bce88f297 cmucl-21a/000077500000000000000000000000001260377556400125615ustar00rootroot00000000000000cmucl-21a/bin/000077500000000000000000000000001260377556400133315ustar00rootroot00000000000000cmucl-21a/bin/build-all.sh000077500000000000000000000103201260377556400155310ustar00rootroot00000000000000#! /bin/sh # Build all variants of cmucl. This means build x87 and sse2 versions # for both unicode and non-unicode variants. # Basically call build.sh to do the builds. usage () { echo "build-all.sh [-bBCvUP] [-o old] [-8 old8bit]" echo "" echo "Build all variants of cmucl for a specific architecture." echo "This means build the unicode and non-unicode variants." echo "This script basically automates calling build.sh for all the" echo "variants, using the most common options. If there are special" echo "requirements, then you must use build.sh itself instead of this" echo "script." echo "" echo " -b d Basename of the different build directories." echo " ${d}-2, ${d}-3, ${d}-4 for unicode" echo " If -b is not given, a suitable name is chosen" echo " based on the OS." echo " ${d}-8bit-2, ${d}-8bit-3, ${d}-8bit-4 for non-unicode" echo " -B file Use file as a boot file. Maybe be specified more than once" echo " The file is relative to the bootfiles/ directory" echo ' -C [l m] Create the build directories. The args are what' echo ' you would give to create-target.sh for the lisp' echo ' and motif variant.' echo ' -v v Use the given string as the version.' echo " -o x Use specified Lisp to build unicode version." echo " (only applicable for build 1)" echo " -8 x DEPRECATED: Use specified Lisp to build 8-bit version." echo " (only applicable for build 1)" echo " -U Update and overwite the translations files." echo " -P On the last build, (re)generate cmucl.pot and the" echo " translations" echo " -R Force recompilation of C runtime" echo " -G Don't use git to fill file-comment information" } CREATE_OPT="" UPDATE_POT="-P" while getopts "PRUGB:b:v:C:o:8:?" arg do case $arg in b) BASE="$OPTARG" ;; B) bootfiles="$bootfiles -B $OPTARG" ;; C) CREATE_OPT="$OPTARG" ;; o) OLDLISP="$OPTARG" ;; 8) OLD8="$OPTARG" echo "WARNING: -8 is deprecated";; v) VERSION="$OPTARG"; VERSION_SET=true ;; U) UPDATE_TRANS="-U" ;; P) UPDATE_POT="" ;; R) RECOMPILEC="-R" ;; G) GIT_FILE_COMMENT="-G" ;; \?) usage; exit 1 ;; esac done # If -b not given, try to derive one instead of just using "build". if [ -z "$BASE" ]; then case `uname -s` in Darwin) case `uname -p` in powerpc) BASE=ppc ;; i386) BASE=darwin ;; esac ;; SunOS) case `uname -m` in sun4u) BASE=sparc ;; i86pc) BASE=sol-x86 ;; esac ;; Linux) BASE=linux ;; # Add support for FreeBSD and NetBSD? Otherwise default to just build. *) BASE=build ;; esac fi if [ "$OLDLISP" = "" -a "$OLD8" = "" ]; then echo "-o or -8 option required" exit 1 fi BINDIR=bin buildx86 () { if [ -n "$OLD8" ]; then # Build non-unicode versions set -x $BINDIR/build.sh -b ${BASE}-8bit $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLD8" set +x fi # Build the unicode versions if [ -n "$OLDLISP" ]; then set -x $BINDIR/build.sh -b ${BASE} $bootfiles ${VERSION:+-v "$VERSION"} -C "${CREATE_OPT}" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLDLISP" set +x fi } buildsun4 () { if [ "$VERSION_SET" = true ]; then VERS="-v '"$VERSION"'" fi # Build non-unicode versions if [ -n "$OLD8" ]; then set -x $BINDIR/build.sh -b ${BASE}-8bit $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLD8" set +x fi # Build the unicode version. if [ -n "$OLDLISP" ]; then set -x $BINDIR/build.sh -b ${BASE} $bootfiles ${VERS} -C "$CREATE_OPT" ${UPDATE_TRANS} ${UPDATE_POT} ${RECOMPILEC} ${GIT_FILE_COMMENT} -o "$OLDLISP" set +x fi } case `uname -m` in i386*|x86*|i86pc) buildx86 ;; sun*|Power\ Mac*) # buildsun4 works for sparc and ppc. buildsun4 ;; *) echo "Unsupported architecture: `uname -m`" ;; esac cmucl-21a/bin/build-utils.sh000077500000000000000000000027361260377556400161350ustar00rootroot00000000000000#!/bin/sh if [ "$1" = "" ] then echo "Usage: $0 target-directory" exit 1 fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi TARGET="`echo $1 | sed 's:/*$::'`" shift $TARGET/lisp/lisp \ -noinit -nositeinit -batch "$@" <". In either of these cases, just assume # make is GNU make. if [ $? -ne 0 ]; then MAKE="make" fi if echo "X$MAKE" | grep '^Xno' > /dev/null; then MAKE="make" fi fi export MAKE # Don't bother building motifd on ppc; we'll probably never support that again. SKIPMOTIF=no case `uname -s` in Darwin) case `uname -p` in powerpc) SKIPMOTIF=yes ;; esac ;; esac if [ "$SKIPMOTIF" = "no" ]; then ${MAKE} -C $TARGET/motif/server clean && ${MAKE} -C $TARGET/motif/server fi cmucl-21a/bin/build-world.sh000077500000000000000000000033461260377556400161220ustar00rootroot00000000000000#!/bin/sh if [ "$1" = "" ] then echo "Usage: $0 target-directory [build-binary] [build-flags...]" exit 1 fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi TARGET="`echo $1 | sed 's:/*$::'`" LISP="${2:-lisp}" if [ $# -ge 2 ] then shift 2 else shift fi if [ -n "$MAKE_POT" ]; then GETFMT="(map nil #'(lambda (f) (stream::find-external-format (car f))) (list-all-external-formats))" SAVEPOT='(intl::dump-pot-files :output-directory "default:src/i18n/locale/")' fi if [ "$GIT_FILE_COMMENT" = "no" ]; then GIT_FILE_COMMENT="(setf c::*file-comment-from-git* nil)" else GIT_FILE_COMMENT= fi $LISP "$@" -noinit -nositeinit <". In either of these cases, just assume # make is GNU make. if [ $? -ne 0 ]; then MAKE="make" fi if echo "X$MAKE" | grep '^Xno' > /dev/null; then MAKE="make" fi fi usage () { echo "build.sh [-123obvuBCUG?]" echo " -1 Skip build 1" echo " -2 Skip build 2" echo " -3 Skip build 3" echo " -o x Use specified Lisp to build. Default is cmulisp" echo " (only applicable for build 1)" echo ' -b d The different build directories are named ${d}-2, ${d}-3 ${d}-4' echo ' If -b is not given, a suitable name based on the OS is used.' echo ' -v v Use the given string as the version. Default is' echo " based on git describe" echo " -u Don't build CLX, CLM, or Hemlock" echo ' -i n Make build "n" interactive, so output is sent to *standard-output*' echo ' instead of the log file. "n" should be a string consisting of' echo ' the numbers 1, 2, or 3.' echo " -B file Use file as a boot file. May be be specified more than once" echo " The file is relative to the bootfiles/ directory" echo ' -C [l m] Create the build directories. The args are what' echo ' you would give to create-target.sh for the lisp' echo ' and motif variant.' echo ' -P On the last build, do NOT generate cmucl.pot and do NOT update' echo ' the translations.' echo " -? This help message" echo " -w Specify a different build-world.sh script" echo " -U If translations are done, overwrite the files with the" echo " translations instead of computing and displaying the diffs." echo " -O opt Any additional command-line flags to use when building." echo " The flags always include -noinit -nositeinit" echo " -R Force recompiling the C runtime. Normally, just runs make to " echo " recompile anything that has changed." echo " -G Don't use git to fill file-comment information" exit 1 } # Figure out if we need to run build-world twice case `uname -s` in SunOS) BUILD_WORLD2=yes ;; Darwin) case `uname -m` in ppc) BUILD_WORLD2=yes ;; esac ;; esac buildit () { if echo $INTERACTIVE_BUILD | grep $BUILD > /dev/null; then INTERACTIVE=t else INTERACTIVE=nil fi if [ ! -d $TARGET ]; then if [ -n "$CREATE_DIRS" ]; then $TOOLDIR/create-target.sh $TARGET $CREATE_OPT fi fi if [ "$ENABLE" = "yes" ]; then $TOOLDIR/clean-target.sh $CLEAN_FLAGS $TARGET || { echo "Failed: $TOOLDIR/clean-target.sh"; exit 1; } time $BUILDWORLD $TARGET $OLDLISP $BOOT || { echo "Failed: $BUILDWORLD"; exit 1; } if [ "$REBUILD_LISP" = "yes" ]; then $TOOLDIR/rebuild-lisp.sh $TARGET else # Set the LANG to C. For whatever reason, if I (rtoy) don't # do this on my openSuSE system, any messages from gcc are # basically garbled. This should be harmless on other # systems. LANG=C $MAKE -C $TARGET/lisp $MAKE_TARGET || { echo "Failed: $MAKE -C $TARGET/lisp"; exit 1; } fi if [ "$BUILD_WORLD2" = "yes" ]; then $BUILDWORLD $TARGET $OLDLISP $BOOT || { echo "Failed: $BUILDWORLD"; exit 1; } fi $TOOLDIR/load-world.sh $TARGET "$VERSION" || { echo "Failed: $TOOLDIR/load-world.sh"; exit 1; } $TARGET/lisp/lisp -batch -noinit -nositeinit $FPU_MODE < /dev/null || { echo "Failed: $TARGET/lisp/lisp -batch -noinit $FPU_MODE"; exit 1; } return 0; fi } FPU_MODE= BUILDWORLD="$TOOLDIR/build-world.sh" BUILD_POT="yes" UPDATE_TRANS= while getopts "123PRGo:b:v:uB:C:Ui:w:O:?" arg do case $arg in 1) ENABLE2="no" ;; 2) ENABLE3="no" ;; 3) ENABLE4="no" ;; o) OLDLISP=$OPTARG ;; b) BASE=$OPTARG ;; v) VERSION="$OPTARG $GIT_HASH" ;; u) SKIPUTILS="yes" ;; C) CREATE_OPT="$OPTARG" CREATE_DIRS=yes ;; B) bootfiles="$bootfiles $OPTARG" ;; i) INTERACTIVE_BUILD="$OPTARG" ;; P) BUILD_POT=no ;; w) BUILDWORLD="$OPTARG" ;; U) UPDATE_TRANS="yes";; O) OLDLISPFLAGS="$OLDLISPFLAGS $OPTARG" ;; R) REBUILD_LISP="yes";; G) GIT_FILE_COMMENT="no";; \?) usage ;; esac done # If -b not given, try to derive one instead of just using "build". if [ -z "$BASE" ]; then case `uname -s` in Darwin) case `uname -p` in powerpc) BASE=ppc ;; i386) BASE=darwin ;; esac ;; SunOS) case `uname -m` in sun4*) BASE=sparc ;; i86pc) BASE=sol-x86 ;; esac ;; Linux) BASE=linux ;; # Add support for FreeBSD and NetBSD? Otherwise default to just build. *) BASE=build ;; esac fi echo base = $BASE bootfiles_dir=$SRCDIR/bootfiles/$version if [ -n "$bootfiles" ]; then for file in $bootfiles; do BOOT="$BOOT -load $bootfiles_dir/$file" done fi build_started=`date` echo "//starting build: $build_started" TARGET=$BASE-2 ENABLE=$ENABLE2 MAKE_TARGET=all export INTERACTIVE BUILD=1 OLDLISP="$OLDLISP $OLDLISPFLAGS" buildit bootfiles= TARGET=$BASE-3 OLDLISP="${BASE}-2/lisp/lisp $OLDLISPFLAGS" ENABLE=$ENABLE3 BUILD=2 # We shouldn't have to run build-world again because nothing should # have changed in the C code after the first build. BUILD_WORLD2= buildit TARGET=$BASE-4 CLEAN_FLAGS="-K all" OLDLISP="${BASE}-3/lisp/lisp $OLDLISPFLAGS" ENABLE=$ENABLE4 if [ "${BUILD_POT}" = "yes" ]; then MAKE_POT=yes if [ "${UPDATE_TRANS}" = "yes" ]; then MAKE_TARGET="all translations-update" else MAKE_TARGET="all translations" fi export MAKE_POT fi BUILD=3 buildit # Asdf and friends are part of the base install, so we need to build # them now. $TARGET/lisp/lisp -noinit -nositeinit -batch << EOF || exit 3 (in-package :cl-user) (setf (ext:search-list "target:") '("$TARGET/" "src/")) (setf (ext:search-list "modules:") '("target:contrib/")) (compile-file "modules:asdf/asdf") (compile-file "modules:defsystem/defsystem") (intl::install) (ext:without-package-locks (let ((path #-linux "modules:unix/unix" #+linux "modules:unix/unix-glibc2")) (ensure-directories-exist (compile-file-pathname path)) (compile-file path))) EOF if [ "$SKIPUTILS" = "no" ]; then OLDLISP="${BASE}-4/lisp/lisp $OLDLISPFLAGS" time $TOOLDIR/build-utils.sh $TARGET fi build_finished=`date` echo echo "//build started: $build_started" echo "//build finished: $build_finished" cmucl-21a/bin/clean-target.sh000077500000000000000000000037451260377556400162470ustar00rootroot00000000000000#!/bin/sh usage() { echo "Usage: `basename $0` [-l] dir [dir1 dir2 ...]" echo " -h This help" echo " -l Clean out the C runtime as well" echo " -K what Specify what to keep: lib, core, all" echo " lib keeps the module libraries" echo " core keeps all lisp core files" echo " all keeps the libs and cores" echo " (for build.sh)" echo "" echo "Cleans out all Lisp fasls from the given directories" echo "If -l is also given, the C runtime is cleared as well. This includes" echo "all object files, the lisp binary itself, and any selected configuration" echo "files. The motif server is also removed." exit 1 } while getopts "h?lK:" arg do case $arg in l) CLEAN_C=1 ;; K) KEEP=$OPTARG ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` if [ $# -lt 1 ]; then usage fi for d in "$@" do if [ ! -d "$d" ]; then echo "$d isn't a directory" exit 2 fi D="`echo $d | sed 's:/*$::'`" TARGET="$TARGET $D" done # Default: don't keep any libraries, and delete an lisp cores GREP="cat" CORE='-o -name "*.core"' if [ -n "$KEEP" ]; then case $KEEP in lib) GREP='egrep -v' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library' ;; core) CORE='' ;; all) GREP='egrep -v' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library|(asdf|defsystem)' CORE='' ;; esac fi find $TARGET -name "*.bytef" -o -name "*.lbytef" -o -name "*.assem" -o \ -name "*.axpf" -o \ -name "*.hpf" -o \ -name "*.pmaxf" -o \ -name "*.sgif" -o \ -name "*.ppcf" -o \ -name "*.sparcf" -o \ -name "*.x86f" -o \ -name "*.sse2f" $CORE | $GREP $PATTERN | xargs rm 2> /dev/null for d in $TARGET do rm -f $d/compile-*.log $d/hemlock/spell-dictionary.bin 2> /dev/null if [ -n "$CLEAN_C" ]; then rm -f $d/lisp/* $d/motif/server/* fi done true cmucl-21a/bin/create-target.sh000077500000000000000000000100521260377556400164150ustar00rootroot00000000000000#!/bin/sh diag() { echo "($prgm_name) $@" >&2; } quit() { diag "not OK: $@"; exit 1; } usage() { echo "Usage: $prgm_name TARGET-DIR [LISP-VARIANT [MOTIF-VARIANT]]" echo "" echo "Creates a directory structure in TARGET-DIR for use in building CMUCL." echo "A simple logic is used to find the optional -VARIANT parameters." echo "" # List possible values for lisp-variant and motif-variant echo "Possible LISP-VARIANTs:" ( cd src/lisp/ && ls -1 Config.* ) | sed 's;^Config[.];;g' | grep -v common | pr -3at -o 8 || quit "Can't list lisp-variants" echo "Possible MOTIF-VARIANTs:" ( cd src/motif/server/ && ls -1 Config.* ) | sed 's;^Config[.];;g' | pr -3at -o 8 || quit "Can't list lisp-variants" exit 2 } ##-- prgm_name=`basename $0` bld_dir=$1 lisp_variant=$2 motif_variant=$3 while getopts "h?" arg do case $arg in h) usage ;; \?) usage ;; esac done bld_dir=$1 lisp_variant=$2 motif_variant=$3 exec 2>&1 [ -n "$bld_dir" ] || usage uname_s=`uname -s` uname_m=`uname -m 2>/dev/null` [ -n "$lisp_variant" ] || { case $uname_s in Linux) lisp_variant=x86_linux ;; FreeBSD) lisp_variant=x86_freebsd ;; SunOS) case $uname_m in i86pc) lisp_variant=x86_solaris_sunc ;; sun*) lisp_variant=sparc_sunc ;; esac ;; Darwin) case $uname_m in ppc) lisp_variant=ppc_darwin ;; i386|x86_64) lisp_variant=x86_darwin ;; esac ;; NetBSD) lisp_variant=x86_netbsd ;; *) quit "Unsupported OS: $uname_s";; esac } [ -n "$lisp_variant" ] || quit "Can't determine lisp_variant" [ -f src/lisp/Config.$lisp_variant ] || quit "Config.$lisp_variant not found" case $lisp_variant in *linux*) lvshort=linux;; *freebsd*) lvshort=freebsd;; *solaris*|sparc*) lvshort=solaris;; *) lvshort=unknown;; esac # Beats me why we care about Motif today but let it be, other than on FreeBSD, # where the config file is wrong anyway. (agoncharov, 2011-10-07) case $uname_s in FreeBSD) :;; # Free *) # Enjoy [ -n "$motif_variant" ] || { case $lisp_variant in NetBSD*) motif_variant=NetBSD ;; OpenBSD*) motif_variant=OpenBSD ;; *_darwin) motif_variant=Darwin ;; sun4_solaris_gcc|sparc_gcc) motif_variant=solaris ;; sun4_solaris_sunc|sparc_sunc|x86_solaris_sunc) motif_variant=solaris_sunc ;; sun4c*) motif_variant=sun4c_411 ;; hp700*) motif_variant=hpux_cc ;; pmax_mach) motif_variant=pmax_mach ;; sgi*) motif_variant=irix ;; x86_linux|linux*) motif_variant=x86 ;; esac } [ -f src/motif/server/Config.$motif_variant ] || quit "No such motif-variant could be found: Config.$motif_variant" ;; esac # Tell user what's we've configured diag "Settings: bld_dir=$bld_dir lisp_variant=$lisp_variant ${motif_variant:+motif_variant=$motif_variant}" # Create a directory tree that mirrors the source directory tree [ -d "$bld_dir" -o -f "$bld_dir" ] && quit "Exists: `ls -ld $bld_dir`" mkdir -p "$bld_dir" (cd src && find . -name .git -prune -o -type d -print) | (cd $bld_dir && xargs mkdir -p) || quit "Can't create target directories" top_dir=$PWD cd $bld_dir/lisp || quit "Can't cd $bld_dir/lisp" # Link Makefile and Config files ln -s ../../src/lisp/GNUmakefile ../../src/lisp/Config.$lisp_variant ../../src/lisp/Config.*_common . ln -s Config.$lisp_variant Config [ -n "$motif_variant" ] && ( cd ../motif/server || quit "Can't cd motif/server" # We will still continue in the outer shell ln -s ../../../src/motif/server/GNUmakefile ./Makefile ln -s ../../../src/motif/server/Config.$motif_variant ./Config ) echo 'Map file for lisp version 0' > lisp.nm # Empty initial map file echo '#error You need to run genesis (via build-world.sh) before compiling the startup code!' > internals.h ( setenv_dir=$top_dir/src/tools/setenv-scripts cat $setenv_dir/base-features.lisp case $lvshort in linux|freebsd) gcname=":gencgc"; sed "s;@@gcname@@;$gcname;" $setenv_dir/$lvshort-features.lisp >> setenv.lisp;; solaris) cat $setenv_dir/solaris-features.lisp;; *) sed "s;@@LISP@@;$lisp_variant;" $setenv_dir/unknown.lisp;; esac ) > ../setenv.lisp || quit "Can't create setenv.lisp" cmucl-21a/bin/cross-build-world.sh000077500000000000000000000055721260377556400172540ustar00rootroot00000000000000#!/bin/sh usage() { echo "cross-build-world.sh [-crl] [-B file] [-G Gnumake] target-dir cross-dir cross-compiler-script [build-binary [flags]]" echo " -c Clean target and cross directories before compiling" echo " -r Recompile lisp runtime" echo " -l Load cross-compiled kernel to make a new lisp kernel" echo " -B file Use this as the cross bootstrap file." echo " -G make Specifies the name of GNU make" } MAKE=make while getopts "crlB:G:" arg do case $arg in c) CLEAN_DIR=yes ;; r) BUILD_RUNTIME=yes ;; l) LOAD_KERNEL=yes ;; B) BOOTSTRAP=$OPTARG ;; G) MAKE=$OPTARG ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` if [ "$1" = "" -o "$2" = "" ] then usage exit 1 fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi if [ -f "$2" ] then echo "$2 exists but isn't a directory" exit 2 fi if [ ! -f "$3" ] then echo "$3 doesn't exist, or isn't a normal file" fi TARGET="`echo $1 | sed 's:/*$::'`" CROSS="`echo $2 | sed 's:/*$::'`" SCRIPT="$3" LISP="${4:-lisp}" if [ -z "$BOOTSTRAP" ]; then CROSSBOOT="$TARGET/cross-bootstrap.lisp" else CROSSBOOT=$BOOTSTRAP fi if [ $# -ge 4 ] then shift 4 else shift 3 fi if [ "$CLEAN_DIR" = "yes" ]; then echo "Cleaning directories: $TARGET $CROSS" bin/clean-target.sh $TARGET $CROSS fi if [ ! -d "$CROSS" ] then # Create a directory tree that mirrors the source directory tree find src -name 'CVS' -prune -o -type d -print | \ sed "s:^src:$CROSS:g" | xargs mkdir fi echo cross boot = $CROSSBOOT $LISP "$@" -noinit -nositeinit < /dev/null; then VERSION="${GIT_HASH}" fi if expr "X${GIT_HASH}" : 'X[0-9][0-9][a-f]' > /dev/null; then VERSION="${GIT_HASH}" fi echo $VERSION while getopts "p" arg do case $arg in p) SKIP_PCL="yes" shift;; \?) usage ;; esac done if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi TARGET="`echo $1 | sed 's:/*$::'`" # If -p given, we want to skip loading of PCL. Do this by pushing # :no-pcl onto *features* if [ -n "$SKIP_PCL" ]; then NO_PCL_FEATURE="(pushnew :no-pcl *features*)" fi # If version string given, use it, otherwise use the default. if [ -n "$2" ]; then VERSION="$2" fi $TARGET/lisp/lisp -core $TARGET/lisp/kernel.core <.tar." echo " If -I is also given, the -S means that the sources are " echo " installed in the /src" echo " dir Directory where the build is located" echo " version Version (usually date and/or other version info)" echo " arch Architecture (x86, sparc, etc.)" echo " os OS (linux, solaris8, etc.)" echo "" echo "If the -I option is given, directly install all of the files to the" echo "specified directory. Otherwise, Make a CMUCL distribution consisting" echo "of two tar files. One holds the main files including the C runtime," echo "the lisp core, and PCL library. The second tar file contains extra" echo "libraries such as CLX, CLM, and Hemlock." echo "" echo "The tar files have the form cmucl---.tar." echo "and cmucl---.extra.tar. where ," echo ", and are given values, and is gz or bz2 depending" echo "on the selected compression method." echo "" echo "If version is not given, then a version is determined automatically" echo "based on the result of git describe." echo "" echo "If arch and os are not given, the script will attempt to figure an" echo "appropriate value for arch and os from the running system." echo "" echo "Creating a source distribution requires GNU tar. If 'tar' is not GNU" echo "tar, use the environment variable 'GTAR' to specify GNU tar. You can" echo "use 'GTAR=gtar make-dist.sh -S ...' in this case." exit 1 } def_arch_os () { case `uname -s` in SunOS) case `uname -m` in sun*) ARCH=sparcv9 ;; i*) ARCH=x86 ;; esac uname_r=`uname -r` case $uname_r in 5.*) rel=`echo $uname_r | sed 's/5\.//'`;; *) rel=$uname_r;; esac OS=solaris$rel ;; Linux) ARCH=x86 OS=linux ;; Darwin) OS=darwin # x86 or ppc? case `uname -m` in i386|x86_64) ARCH=x86 ;; *) ARCH=ppc ;; esac ;; NetBSD) ARCH=x86 OS=netbsd ;; FreeBSD) ARCH=x86 OS=freebsd_`uname -r | tr 'A-Z' 'a-z'` ;; esac } while getopts "G:O:I:M:bghS?" arg do case $arg in G) GROUP=$OPTARG ;; O) OWNER=$OPTARG ;; I) INSTALL_DIR=$OPTARG ;; M) MANDIR=$OPTARG ;; b) ENABLE_BZIP=-b ;; g) ENABLE_GZIP=-g ;; S) MAKE_SRC_DIST=yes ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` # Figure out the architecture and OS ARCH= OS= # Figure out the architecture and OS def_arch_os if [ -n "${INSTALL_DIR}" ]; then # Doing direct installation if [ $# -lt 1 ]; then usage else def_arch_os fi elif [ $# -lt 2 ]; then # Version not specified so choose a version based on the git hash. GIT_HASH="`(cd src; git describe --dirty 2>/dev/null)`" if expr "X${GIT_HASH}" : 'Xsnapshot-[0-9][0-9][0-9][0-9]-[01][0-9]' > /dev/null; then VERSION=`expr "${GIT_HASH}" : "snapshot-\(.*\)"` fi if expr "X${GIT_HASH}" : 'X[0-9][0-9][a-f]' > /dev/null; then VERSION="${GIT_HASH}" fi echo "Defaulting version to $VERSION" else VERSION="$2" if [ $# -eq 3 ]; then ARCH=$3 elif [ $# -eq 4 ]; then ARCH=$3 OS=$4 fi fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi if [ -z "$INSTALL_DIR" ]; then if [ -z "$ARCH" ]; then echo "Unknown architecture. Please specify one" usage fi if [ -z "$OS" ]; then echo "Unknown OS. Please specify one" usage fi fi TARGET="`echo $1 | sed 's:/*$::'`" if [ -n "$INSTALL_DIR" ]; then VERSION="today" fi ROOT=`dirname $0` # If no compression options given, default to bzip if [ -z "$ENABLE_GZIP" -a -z "$ENABLE_BZIP" ]; then ENABLE_BZIP="-b" fi OPTIONS="${GROUP:+ -G ${GROUP}} ${OWNER:+ -O ${OWNER}} ${INSTALL_DIR:+ -I ${INSTALL_DIR}} $ENABLE_GZIP $ENABLE_BZIP" MANDIR="${MANDIR:+ -M ${MANDIR}}" echo Creating distribution for $ARCH $OS $ROOT/make-main-dist.sh $OPTIONS ${MANDIR} $TARGET $VERSION $ARCH $OS || exit 1 $ROOT/make-extra-dist.sh $OPTIONS $TARGET $VERSION $ARCH $OS || exit 2 if [ X"$MAKE_SRC_DIST" = "Xyes" ]; then # If tar is not GNU tar, set the environment variable GTAR to # point to GNU tar. OPTIONS="${INSTALL_DIR:+ -I ${INSTALL_DIR}} $ENABLE_GZIP $ENABLE_BZIP" $ROOT/make-src-dist.sh $OPTIONS -t ${GTAR:-tar} $VERSION fi cmucl-21a/bin/make-extra-dist.sh000077500000000000000000000100501260377556400166630ustar00rootroot00000000000000#!/bin/sh while getopts "G:O:I:bgh?" arg do case $arg in G) GROUP="-g $OPTARG" ;; O) OWNER="-o $OPTARG" ;; I) INSTALL_DIR=$OPTARG ;; b) ENABLE_BZIP=-b ;; g) ENABLE_GZIP=-g ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` if [ "$1" = "" -o "$2" = "" -o "$3" = "" -o "$4" = "" ] then echo "Usage: $0 target-directory version arch os" exit 1 fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi DESTDIR=${INSTALL_DIR:-release-$$} TARGET="`echo $1 | sed 's:/*$::'`" VERSION=$2 ARCH=$3 OS=$4 case $ARCH in x86*) FASL="sse2f" ;; sparc*) FASL=sparcf ;; alpha*) FASL=axpf ;; ppc*) FASL=ppcf ;; mips*) FASL=sgif ;; *) echo "Unknown FASL type for architecture $ARCH" exit 2 ;; esac # Frob PATH to use /usr/ucb/install for Solaris if [ `uname -s` = "SunOS" ] then PATH=/usr/ucb:$PATH fi if [ -z "$INSTALL_DIR" ]; then echo Cleaning $DESTDIR [ -d $DESTDIR ] && rm -rf $DESTDIR fi echo Installing extra components install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/subsystems install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib for ext in $FASL do install ${GROUP} ${OWNER} -m 0644 $TARGET/clx/clx-library.$ext \ $DESTDIR/lib/cmucl/lib/subsystems/ install ${GROUP} ${OWNER} -m 0644 $TARGET/hemlock/hemlock-library.$ext \ $DESTDIR/lib/cmucl/lib/subsystems/ install ${GROUP} ${OWNER} -m 0644 $TARGET/interface/clm-library.$ext \ $DESTDIR/lib/cmucl/lib/subsystems/ done # Not sure we really need these, but we'll install them in the # ext-formats directory. (Should they go somewhere else?) #install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/ext-formats #for f in src/i18n/NameAliases.txt src/i18n/UnicodeData.txt #do # echo $f # install ${GROUP} ${OWNER} -m 0644 $f $DESTDIR/lib/cmucl/lib/ext-formats/ #done # install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/fonts/ # install ${GROUP} ${OWNER} -m 0644 misc/8x13u.snf misc/fonts.dir \ # $DESTDIR/lib/cmucl/lib/fonts/ install ${GROUP} ${OWNER} -m 0644 src/hemlock/XKeysymDB \ src/hemlock/hemlock11.cursor src/hemlock/hemlock11.mask \ $TARGET/hemlock/spell-dictionary.bin \ $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0755 src/hemlock/mh-scan $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0755 $TARGET/motif/server/motifd \ $DESTDIR/lib/cmucl/lib/ # Install the contrib stuff. Create the directories and then copy the files. for d in `(cd src; find contrib -type d -print | egrep -v "CVS|asdf|defsystem")` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done for f in `(cd src/contrib; find . -type f -print | egrep -v "CVS|asdf|defsystem|unix")` do FILE=`basename $f` DIR=`dirname $f` install ${GROUP} ${OWNER} -m 0644 src/contrib/$f $DESTDIR/lib/cmucl/lib/contrib/$DIR done # Install all the locale data. for d in `(cd src/i18n/; find locale -type d -print | egrep -v CVS)` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done # Install mo files. for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` do FILE=`basename $f` DIR=`dirname $f` install ${GROUP} ${OWNER} -m 0644 $TARGET/i18n/$f $DESTDIR/lib/cmucl/lib/$DIR done # Install po files. (Do we really need to distribute the po files?) #for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` #do # FILE=`basename $f` # DIR=`dirname $f` # install ${GROUP} ${OWNER} -m 0644 $TARGET/i18n/$f $DESTDIR/lib/cmucl/lib/$DIR #done if [ -z "$INSTALL_DIR" ]; then sync ; sleep 1 ; sync ; sleep 1 ; sync echo Tarring extra components if [ -n "$ENABLE_GZIP" ]; then echo " Compressing with gzip" ( cd $DESTDIR >/dev/null ; tar cf - lib ) | \ gzip -c > cmucl-$VERSION-$ARCH-$OS.extra.tar.gz fi if [ -n "$ENABLE_BZIP" ]; then echo " Compressing with bzip" ( cd $DESTDIR >/dev/null ; tar cf - lib ) | \ bzip2 > cmucl-$VERSION-$ARCH-$OS.extra.tar.bz2 fi echo Cleaning $DESTDIR [ -d $DESTDIR ] && rm -rf $DESTDIR echo Done fi cmucl-21a/bin/make-main-dist.sh000077500000000000000000000125551260377556400165000ustar00rootroot00000000000000#!/bin/sh # set -x while getopts "G:O:I:M:bgh?" arg do case $arg in G) GROUP="-g $OPTARG" ;; O) OWNER="-o $OPTARG" ;; I) INSTALL_DIR=$OPTARG ;; M) MANDIR=$OPTARG ;; b) ENABLE_BZIP=-b ;; g) ENABLE_GZIP=-g ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` if [ "$1" = "" -o "$2" = "" -o "$3" = "" -o "$4" = "" ] then echo "Usage: $0 target-directory version arch os" exit 1 fi if [ ! -d "$1" ] then echo "$1 isn't a directory" exit 2 fi DESTDIR=${INSTALL_DIR:-release-$$} DOCDIR=${DOCDIR:-doc/cmucl} MANDIR=${MANDIR:-man/man1} TARGET="`echo $1 | sed 's:/*$::'`" VERSION=$2 ARCH=$3 OS=$4 # Core file to look for. CORE=lisp.core case $ARCH in x86*) FASL=sse2f CORE="lisp-sse2.core" ;; sparc*) FASL=sparcf ;; alpha*) FASL=axpf ;; ppc*) FASL=ppcf ;; mips*) FASL=sgif ;; *) echo "Unknown FASL type for architecture $ARCH" exit 2 ;; esac case $OS in freebsd*) EXECUTABLE=true SCRIPT=FreeBSD ;; linux*) EXECUTABLE=true SCRIPT=Linux ;; solaris*) EXECUTABLE=true SCRIPT=SunOS ;; darwin*) EXECUTABLE=true ;; *) EXECUTABLE="" ;; esac # Frob PATH to use /usr/ucb/install for Solaris if [ `uname -s` = "SunOS" ] then PATH=/usr/ucb:$PATH fi if [ -z "$INSTALL_DIR" ]; then # Clean out DESTDIR, if we're not installing there. echo Cleaning $DESTDIR [ -d $DESTDIR ] && rm -rf $DESTDIR fi # set -x echo Installing main components install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/bin install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/subsystems install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/ext-formats install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/${DOCDIR} install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/${MANDIR} install ${GROUP} ${OWNER} -m 0755 $TARGET/lisp/lisp $DESTDIR/bin/ if [ "$EXECUTABLE" = "true" ] then install ${GROUP} ${OWNER} -m 0755 $TARGET/lisp/lisp.a $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0755 src/tools/linker.sh $DESTDIR/lib/cmucl/lib/ if [ -f src/tools/$SCRIPT-cmucl-linker-script ]; then install ${GROUP} ${OWNER} -m 0755 src/tools/$SCRIPT-cmucl-linker-script $DESTDIR/lib/cmucl/lib/ fi fi for corefile in $TARGET/lisp/$CORE do install ${GROUP} ${OWNER} -m 0644 $corefile $DESTDIR/lib/cmucl/lib/ done install ${GROUP} ${OWNER} -m 0755 src/tools/load-foreign.csh src/tools/config \ $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0644 src/tools/config.lisp \ $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0644 src/code/generic-site.lisp \ $DESTDIR/lib/cmucl/lib/ install ${GROUP} ${OWNER} -m 0644 $TARGET/lisp/lisp.nm $TARGET/lisp/lisp.map \ $TARGET/lisp/internals.h $TARGET/lisp/internals.inc $DESTDIR/lib/cmucl/ install ${GROUP} ${OWNER} -m 0755 src/tools/sample-wrapper $DESTDIR/lib/cmucl/ for f in gray-streams gray-compat simple-streams iodefs do install ${GROUP} ${OWNER} -m 0644 $TARGET/pcl/$f-library.$FASL $DESTDIR/lib/cmucl/lib/subsystems/ done for f in src/pcl/simple-streams/external-formats/*.lisp src/pcl/simple-streams/external-formats/aliases src/i18n/unidata.bin do install ${GROUP} ${OWNER} -m 0644 $f $DESTDIR/lib/cmucl/lib/ext-formats/ done # set -x # Create the directories for asdf and defsystem for f in asdf defsystem asdf/doc do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib/$f done case `uname -s` in Linux*) UCONTRIB="unix-glibc2" ;; *) UCONTRIB="unix" ;; esac install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib/unix install ${GROUP} ${OWNER} -m 0644 $TARGET/contrib/unix/$UCONTRIB.$FASL $DESTDIR/lib/cmucl/lib/contrib/unix install ${GROUP} ${OWNER} -m 0644 src/contrib/load-unix.lisp $DESTDIR/lib/cmucl/lib/contrib install ${GROUP} ${OWNER} -m 0644 src/contrib/unix/${UCONTRIB}.lisp $DESTDIR/lib/cmucl/lib/contrib/unix # Copy the source files for asdf and defsystem for f in `(cd src; find contrib/asdf contrib/defsystem -type f -print | grep -v CVS)` do install ${GROUP} ${OWNER} -m 0644 src/$f $DESTDIR/lib/cmucl/lib/$f done # Install the fasl files for asdf and defsystem for f in asdf defsystem do install ${GROUP} ${OWNER} -m 0644 $TARGET/contrib/$f/$f.$FASL $DESTDIR/lib/cmucl/lib/contrib/$f done # Install the docs for asdf for f in src/contrib/asdf/doc/* do base=`basename $f` install ${GROUP} ${OWNER} -m 0644 $f $DESTDIR/lib/cmucl/lib/contrib/asdf/doc/$base done install ${GROUP} ${OWNER} -m 0644 src/general-info/cmucl.1 \ $DESTDIR/${MANDIR}/ install ${GROUP} ${OWNER} -m 0644 src/general-info/lisp.1 \ $DESTDIR/${MANDIR}/ install ${GROUP} ${OWNER} -m 0644 src/general-info/README $DESTDIR/${DOCDIR} if [ -f src/general-info/release-$VERSION.txt ] then install ${GROUP} ${OWNER} -m 0644 src/general-info/release-$VERSION.txt \ $DESTDIR/${DOCDIR} fi if [ -z "$INSTALL_DIR" ]; then sync ; sleep 1 ; sync ; sleep 1 ; sync echo Tarring main components if [ -n "$ENABLE_GZIP" ]; then echo " Compressing with gzip" ( cd $DESTDIR >/dev/null ; tar cf - . ) | \ gzip -c > cmucl-$VERSION-$ARCH-$OS.tar.gz fi if [ -n "$ENABLE_BZIP" ]; then echo " Compressing with bzip" ( cd $DESTDIR >/dev/null ; tar cf - . ) | \ bzip2 > cmucl-$VERSION-$ARCH-$OS.tar.bz2 fi echo Cleaning $DESTDIR [ -d $DESTDIR ] && rm -rf $DESTDIR echo Done fi cmucl-21a/bin/make-src-dist.sh000077500000000000000000000030541260377556400163350ustar00rootroot00000000000000#!/bin/sh usage() { echo "make-src-dist.sh: [-bgh] [-t gnutar] [-I destdir] version" echo " -h This help" echo " -b Use bzip2 compression" echo " -g Use gzip compression" echo " -t tar Name/path to GNU tar" echo " -I destdir Install directly to given directory instead of creating a tarball" echo "" echo 'Create a tar ball of the cmucl sources. The tarball is named ' echo 'cmucl-src-$version.tar.bz2 (or gz if using gzip compression)' } while getopts "bgh?t:I:" arg do case $arg in b) ENABLE_BZIP=-b ;; g) ENABLE_GZIP=-g ;; t) GTAR=$OPTARG ;; I) INSTALL_DIR=$OPTARG ;; h | \?) usage; exit 1 ;; esac done shift `expr $OPTIND - 1` # If no compression given, default to gzip (on the assumption that # that is available everywhere.) if [ -z "$ENABLE_BZIP" -a -z "$ENABLE_GZIP" ]; then ENABLE_GZIP=-b fi # If no version is given, default to today's date if [ -n "$1" ]; then VERSION=$1 else VERSION="`date '+%Y-%m-%d-%H:%M:%S'`" fi echo Creating source distribution if [ -n "$ENABLE_GZIP" ]; then ZIP="gzip -c" ZIPEXT="gz" fi if [ -n "$ENABLE_BZIP" ]; then ZIP="bzip2" ZIPEXT="bz2" fi GTAR_OPTIONS="--exclude=.git --exclude='*.pot.~*~'" if [ -z "$INSTALL_DIR" ]; then echo " Compressing with $ZIP" ${GTAR:-tar} ${GTAR_OPTIONS} -cf - bin src tests | ${ZIP} > cmucl-src-$VERSION.tar.$ZIPEXT else # Install in the specified directory ${GTAR:-tar} ${GTAR_OPTIONS} -cf - bin src tests | (cd $INSTALL_DIR; ${GTAR:-tar} xf -) fi cmucl-21a/bin/rebuild-lisp.sh000077500000000000000000000012211260377556400162570ustar00rootroot00000000000000#!/bin/sh while getopts "h?" arg do case $arg in h) usage ;; \?) usage ;; esac done usage() { echo "rebuild.-lisp.sh [-h?] target-directory" echo " -h this help" echo " -? this help" echo "" echo "Force recompiling all the C code in the specified directory". } shift `expr $OPTIND - 1` if [ "$1" = "" ] then usage exit 1 fi if [ ! -d "$1" ] then echo "$1" must be a directory. exit 2 fi TARGET="`echo $1 | sed 's:/*$::'`" # Find GNU make: if [ "$MAKE" = "" ] then MAKE="`which gmake`" || MAKE="`which make`" fi export MAKE ${MAKE} -C $TARGET/lisp clean && ${MAKE} -C $TARGET/lisp cmucl-21a/src/000077500000000000000000000000001260377556400133505ustar00rootroot00000000000000cmucl-21a/src/assembly/000077500000000000000000000000001260377556400151675ustar00rootroot00000000000000cmucl-21a/src/assembly/alpha/000077500000000000000000000000001260377556400162545ustar00rootroot00000000000000cmucl-21a/src/assembly/alpha/alloc.lisp000066400000000000000000000012771260377556400202460ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/alpha/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocation of stuff we don't want to do inline. ;;; ;;; Written by William Lott. ;;; (in-package "ALPHA") ;;; Given that the pseudo-atomic sequence is so short, there is ;;; nothing that qualifies. But we want to keep the file around ;;; in case we decide to add something later. cmucl-21a/src/assembly/alpha/arith.lisp000066400000000000000000000277431260377556400202710ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/alpha/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; Conversion by Sean Hallgren ;;; (in-package "ALPHA") (define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp temp3 non-descriptor-reg nl2-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst addq x y res) ; Check to see if we need a bignum (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) ; From move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) (inst cmoveq temp 1 temp2) (inst not temp temp) (inst cmoveq temp 1 temp2) (inst sll temp2 type-bits temp2) (inst bis temp2 bignum-type temp2) (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) (inst bis alloc-tn other-pointer-type res) (storew temp2 res 0 other-pointer-type) (storew temp3 res bignum-digits-offset other-pointer-type) (inst srl temp3 32 temp) (storew temp res (1+ bignum-digits-offset) other-pointer-type)) DONE (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst ldl lip (static-function-offset 'two-arg-+) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip)) (define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp temp3 non-descriptor-reg nl2-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst subq x y res) ; Check to see if we need a bignum (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) ; From move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) (inst cmoveq temp 1 temp2) (inst not temp temp) (inst cmoveq temp 1 temp2) (inst sll temp2 type-bits temp2) (inst bis temp2 bignum-type temp2) (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) (inst bis alloc-tn other-pointer-type res) (storew temp2 res 0 other-pointer-type) (storew temp3 res bignum-digits-offset other-pointer-type) (inst srl temp3 32 temp) (storew temp res (1+ bignum-digits-offset) other-pointer-type)) DONE (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst ldl lip (static-function-offset 'two-arg--) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip)) (define-assembly-routine (generic-* (:cost 25) (:return-style :full-call) (:translate *) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) (:temp temp2 non-descriptor-reg nl3-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) ;; Remove the tag from one arg so that the result will have the correct ;; fixnum tag. (inst sra x 2 temp) (inst mulq temp y lo) (inst sra lo 32 hi) (inst sll lo 32 res) (inst sra res 32 res) ;; Check to see if the result will fit in a fixnum. (I.e. the high word ;; is just 32 copies of the sign bit of the low word). (inst sra res 31 temp) (inst xor hi temp temp) (inst beq temp DONE) ;; Shift the double word hi:res down two bits into hi:low to get rid of the ;; fixnum tag. (inst sra lo 2 lo) (inst sra lo 32 hi) ;; Do we need one word or two? Assume two. (inst li (logior (ash 2 type-bits) bignum-type) temp2) (inst sra lo 31 temp) (inst xor temp hi temp) (inst bne temp two-words) ;; Only need one word, fix the header. (inst li (logior (ash 1 type-bits) bignum-type) temp2) ;; Allocate one word. (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) (inst bis alloc-tn other-pointer-type res) (storew temp2 res 0 other-pointer-type)) ;; Store one word (storew lo res bignum-digits-offset other-pointer-type) ;; Out of here (lisp-return lra lip :offset 2) TWO-WORDS ;; Allocate two words. (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset))) (inst bis alloc-tn other-pointer-type res) (storew temp2 res 0 other-pointer-type)) ;; Store two words. (storew lo res bignum-digits-offset other-pointer-type) (storew hi res (1+ bignum-digits-offset) other-pointer-type) ;; Out of here (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst ldl lip (static-function-offset 'two-arg-*) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip) DONE) ;;;; Division. (define-assembly-routine (signed-truncate (:note "(signed-byte 32) truncate") (:cost 60) (:policy :fast-safe) (:translate truncate) (:arg-types signed-num signed-num) (:result-types signed-num signed-num)) ((:arg dividend signed-reg nl0-offset) (:arg divisor signed-reg nl1-offset) (:res quo signed-reg nl2-offset) (:res rem signed-reg nl3-offset) (:temp quo-sign signed-reg nl5-offset) (:temp rem-sign signed-reg nargs-offset) (:temp temp1 non-descriptor-reg nl4-offset)) (let ((error (generate-error-code nil division-by-zero-error dividend divisor))) (inst beq divisor error)) (inst xor dividend divisor quo-sign) (inst move dividend rem-sign) (let ((label (gen-label))) (inst bge dividend label) (inst subq zero-tn dividend dividend) (emit-label label)) (let ((label (gen-label))) (inst bge divisor label) (inst subq zero-tn divisor divisor) (emit-label label)) (inst move zero-tn rem) (inst move zero-tn quo) (inst sll dividend 32 dividend) (dotimes (i 32) (inst srl dividend 63 temp1) (inst sll rem 1 rem) (inst bis temp1 rem rem) (inst cmple divisor rem temp1) (inst sll quo 1 quo) (inst bis temp1 quo quo) (inst sll dividend 1 dividend) (inst subq temp1 1 temp1) (inst zap divisor temp1 temp1) (inst subq rem temp1 rem)) (let ((label (gen-label))) ;; If the quo-sign is negative, we need to negate quo. (inst bge quo-sign label) (inst subq zero-tn quo quo) (emit-label label)) (let ((label (gen-label))) ;; If the rem-sign is negative, we need to negate rem. (inst bge rem-sign label) (inst subq zero-tn rem rem) (emit-label label))) ;;;; Comparison routines. (macrolet ((define-cond-assem-rtn (name translate static-fn cmp not-p) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) (inst beq temp DO-COMPARE) DO-STATIC-FN (inst ldl lip (static-function-offset ',static-fn) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip) DO-COMPARE ,cmp (inst move null-tn res) (inst ,(if not-p 'bne 'beq) temp done) (load-symbol res t) DONE))) (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst cmpeq x y temp) (inst bne temp RETURN-T) (inst and x 3 temp) (inst beq temp RETURN-NIL) (inst and y 3 temp) (inst bne temp DO-STATIC-FN) RETURN-NIL (inst move null-tn res) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst ldl lip (static-function-offset 'eql) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) (inst bne temp DO-STATIC-FN) (inst cmpeq x y temp) (inst bne temp RETURN-T) (inst move null-tn res) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst ldl lip (static-function-offset 'two-arg-=) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-/= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate /=) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) (inst bne temp DO-STATIC-FN) (inst cmpeq x y temp) (inst bne temp RETURN-NIL) (load-symbol res t) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst ldl lip (static-function-offset 'two-arg-=) null-tn) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst move csp-tn cfp-tn) (inst jmp zero-tn lip) RETURN-NIL (inst move null-tn res)) cmucl-21a/src/assembly/alpha/array.lisp000066400000000000000000000120471260377556400202670ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/alpha/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; Conversion by Sean Hallgren ;;; (in-package "ALPHA") (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset)) ;; This is kinda sleazy, changing words like this. But we can because ;; the vop thinks it is temporary. (inst addq words (+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes)) words) (inst li (lognot lowtag-mask) ndescr) (inst and words ndescr words) (inst srl type word-shift ndescr) (pseudo-atomic () (inst bis alloc-tn other-pointer-type result) (inst addq alloc-tn words alloc-tn) (storew ndescr result 0 other-pointer-type) (storew length result vector-length-slot other-pointer-type))) ;;;; Hash primitives (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp lip interior-reg lip-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp byte non-descriptor-reg nl2-offset) (:temp retaddr non-descriptor-reg nl3-offset) (:temp temp1 non-descriptor-reg nl4-offset)) ;; These are needed after we jump into sxhash-simple-substring. (progn result lip accum data byte retaddr) (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1) (loadw length string vector-length-slot other-pointer-type) (inst jmp zero-tn temp1 (make-fixup 'sxhash-simple-substring :assembly-routine))) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp byte non-descriptor-reg nl2-offset) (:temp retaddr non-descriptor-reg nl3-offset)) ;; Save the return address (inst subq lip code-tn retaddr) ;; Get a pointer to the data. (inst addq string (- (* vector-data-offset word-bytes) other-pointer-type) lip) (move zero-tn accum) (inst br zero-tn test) loop (inst and data #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst srl data 8 byte) (inst and byte #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst srl data 16 byte) (inst and byte #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst srl data 24 byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst addq lip 4 lip) test (inst subq length (fixnumize 4) length) (inst ldl data 0 lip) (inst bge length loop) (inst addq length (fixnumize 3) length) (inst beq length one-more) (inst subq length (fixnumize 1) length) (inst beq length two-more) (inst bne length done) (inst srl data 16 byte) (inst and byte #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst addq length (fixnumize 1) length) two-more (inst subq length (fixnumize 1) length) (inst srl data 8 byte) (inst and byte #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) (inst addq length (fixnumize 1) length) one-more (inst subq length (fixnumize 1) length) (inst and data #xff byte) (inst xor accum byte accum) (inst sll accum 5 byte) (inst srl accum 27 accum) (inst mskll accum 4 accum) (inst bis accum byte accum) done (inst sll accum 5 result) (inst mskll result 4 result) (inst srl result 3 result) ;; Restore the return address. (inst addq code-tn retaddr lip)) cmucl-21a/src/assembly/alpha/assem-rtns.lisp000066400000000000000000000155201260377556400212440ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/alpha/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "ALPHA") ;;;; Return-multiple with other than one value #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) (:temp ocfp any-reg nl1-offset) (:temp lra descriptor-reg lra-offset) ;; These are just needed to facilitate the transfer (:temp lip interior-reg lip-offset) (:temp count any-reg nl2-offset) (:temp dst any-reg nl4-offset) (:temp temp descriptor-reg l0-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Note, because of the way the return-multiple vop is written, we can ;; assume that we are never called with nvals == 1 and that a0 has already ;; been loaded. (inst ble nvals default-a0-and-on) (inst ldl a1 (* 1 vm:word-bytes) vals) (inst subq nvals (fixnumize 2) count) (inst ble count default-a2-and-on) (inst ldl a2 (* 2 vm:word-bytes) vals) (inst subq nvals (fixnumize 3) count) (inst ble count default-a3-and-on) (inst ldl a3 (* 3 vm:word-bytes) vals) (inst subq nvals (fixnumize 4) count) (inst ble count default-a4-and-on) (inst ldl a4 (* 4 vm:word-bytes) vals) (inst subq nvals (fixnumize 5) count) (inst ble count default-a5-and-on) (inst ldl a5 (* 5 vm:word-bytes) vals) (inst subq nvals (fixnumize 6) count) (inst ble count done) ;; Copy the remaining args to the top of the stack. (inst addq vals (* 6 vm:word-bytes) vals) (inst addq cfp-tn (* 6 vm:word-bytes) dst) LOOP (inst ldl temp 0 vals) (inst addq vals vm:word-bytes vals) (inst stl temp 0 dst) (inst subq count (fixnumize 1) count) (inst addq dst vm:word-bytes dst) (inst bne count loop) (inst br zero-tn done) DEFAULT-A0-AND-ON (inst move null-tn a0) (inst move null-tn a1) DEFAULT-A2-AND-ON (inst move null-tn a2) DEFAULT-A3-AND-ON (inst move null-tn a3) DEFAULT-A4-AND-ON (inst move null-tn a4) DEFAULT-A5-AND-ON (inst move null-tn a5) DONE ;; Clear the stack. (move cfp-tn ocfp-tn) (move ocfp cfp-tn) (inst addq ocfp-tn nvals csp-tn) ;; Return. (lisp-return lra lip)) ;;;; tail-call-variable. #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) (:temp lexenv descriptor-reg lexenv-offset) ;; We need to compute this (:temp nargs any-reg nargs-offset) ;; These are needed by the blitting code. (:temp src any-reg nl1-offset) (:temp dst any-reg nl2-offset) (:temp count any-reg cfunc-offset) (:temp temp descriptor-reg l0-offset) ;; Needed for the jump (:temp lip interior-reg lip-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Calculate NARGS (as a fixnum) (inst subq csp-tn args nargs) ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst ldl a0 (* 0 vm:word-bytes) args) (inst ldl a1 (* 1 vm:word-bytes) args) (inst ldl a2 (* 2 vm:word-bytes) args) (inst ldl a3 (* 3 vm:word-bytes) args) (inst ldl a4 (* 4 vm:word-bytes) args) (inst ldl a5 (* 5 vm:word-bytes) args) ;; Calc SRC, DST, and COUNT (inst subq nargs (fixnumize register-arg-count) count) (inst addq args (* vm:word-bytes register-arg-count) src) (inst ble count done) (inst addq cfp-tn (* vm:word-bytes register-arg-count) dst) LOOP ;; Copy one arg. (inst ldl temp 0 src) (inst addq src vm:word-bytes src) (inst stl temp 0 dst) (inst subq count (fixnumize 1) count) (inst addq dst vm:word-bytes dst) (inst bgt count loop) DONE ;; We are done. Do the jump. (progn (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) (lisp-jump temp lip))) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) a0-offset) (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset) (:temp temp1 non-descriptor-reg nl3-offset)) (declare (ignore start count)) (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) (let ((error (generate-error-code nil invalid-unwind-error))) (inst beq block error)) (loadw target-uwp block vm:unwind-block-current-uwp-slot) (inst cmpeq cur-uwp target-uwp temp1) (inst beq temp1 do-uwp) (move block cur-uwp) do-exit (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) (progn (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) (lisp-return lra lip :frob-code nil)) do-uwp (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) (store-symbol-value next-uwp lisp::*current-unwind-protect-block*) (inst br zero-tn do-exit)) (define-assembly-routine throw ((:arg target descriptor-reg a0-offset) (:arg start any-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset) (:temp temp1 non-descriptor-reg nl0-offset)) (progn start count) ; We just need them in the registers. (load-symbol-value catch lisp::*current-catch-block*) loop (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst beq catch error)) (loadw tag catch vm:catch-block-tag-slot) (inst cmpeq tag target temp1) (inst bne temp1 exit) (loadw catch catch vm:catch-block-previous-catch-slot) (inst br zero-tn loop) exit (move catch target) (inst li (make-fixup 'unwind :assembly-routine) temp1) (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine))) cmucl-21a/src/assembly/alpha/support.lisp000066400000000000000000000046361260377556400206720ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/alpha/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; (in-package "ALPHA") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (values `((inst li (make-fixup ',name :assembly-routine) temp) (inst jsr lip-tn temp)) '((:temporary (:sc non-descriptor-reg) temp)) nil)) (:full-call (let ((temp (make-symbol "TEMP")) (nfp-save (make-symbol "NFP-SAVE")) (lra (make-symbol "LRA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn ,nfp-save cur-nfp)) (inst compute-lra-from-code ,lra code-tn lra-label ,temp) (note-next-instruction ,vop :call-site) ; here (inst li (make-fixup ',name :assembly-routine) temp1) (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) (emit-return-pc lra-label) (note-this-location ,vop :single-value-return) (without-scheduling () (move ocfp-tn csp-tn) (inst nop)) (inst compute-code-from-lra code-tn code-tn lra-label ,temp) (when cur-nfp (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save) (:temporary (:scs (non-descriptor-reg)) temp1) (:save-p t))))) (:none (values `((inst li (make-fixup ',name :assembly-routine) temp) (inst jsr lip-tn temp (make-fixup ',name :assembly-routine))) '((:temporary (:scs (non-descriptor-reg)) temp)) nil)))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst ret zero-tn lip-tn))) (:full-call `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg) :offset lra-offset) lip-tn :offset 2))) (:none))) cmucl-21a/src/assembly/amd64/000077500000000000000000000000001260377556400161025ustar00rootroot00000000000000cmucl-21a/src/assembly/amd64/alloc.lisp000066400000000000000000000000531260377556400200630ustar00rootroot00000000000000;; Just a dummy file to keep comcom happy. cmucl-21a/src/assembly/amd64/arith.lisp000066400000000000000000000274631260377556400201160ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/amd64/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; Debugged by Paul Werkowski -- Spring/Summer 1995. ;;; (in-package :amd64) (eval-when (compile eval) ;;;; Addition, Subtraction, and Multiplication (defmacro define-generic-arith-routine ((fun cost) &body body) `(define-assembly-routine (,(symbolicate "GENERIC-" fun) (:cost ,cost) (:return-style :full-call) (:translate ,fun) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) ;; this seems wrong esi-offset rdi-offset) (:res res (descriptor-reg any-reg) rdx-offset) (:temp rax unsigned-reg rax-offset) (:temp rbx unsigned-reg rbx-offset) (:temp rcx unsigned-reg rcx-offset) (:temp r11 unsigned-reg r11-offset)) (inst test x 3) ; fixnum? (inst jmp :nz DO-STATIC-FUN) ; no - do generic (inst test y 3) ; fixnum? (inst jmp :z DO-BODY) ; yes - doit here DO-STATIC-FUN (inst pop rax) (inst push rbp-tn) (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes)) (inst sub rsp-tn (* 2 word-bytes)) (inst push rax) ; callers return addr (inst mov rcx (fixnumize 2)) ; arg count (inst mov rbx (+ nil-value (static-function-offset ',(symbolicate "TWO-ARG-" fun)))) (inst jmp (make-ea :qword :base rbx)) DO-BODY ,@body)) ); eval-when (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no OKAY) (inst rcr res 1) ; carry has correct sign (inst sar res 1) ; remove type bits (move rcx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) r11) (storew rcx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (- 10) ;;; I can't figure out the flags on subtract. Overflow never gets ;;; set and carry always does. (- 0 most-negative-fixnum) can't be ;;; easily detected so just let the upper level stuff do it. (inst jmp DO-STATIC-FUN) ;; this is junk code. clean this up!!! (move res x) (inst sub res y) (inst jmp :no OKAY) (inst rcr res 1) (inst sar res 1) ; remove type bits (move rcx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) r11) (storew rcx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (* 30) (move rax x) ; must use rax for 64-bit result (inst sar rax 2) ; remove *4 fixnum bias (inst imul y) ; result in rdx:eax (inst jmp :no okay) ; still fixnum ;; zzz jrd changed rdx to rbx in here, as rdx isn't listed as a temp, above ;; pfw says that loses big -- rdx is target for arg x and result res ;; note that 'rdx' is not defined -- using x (inst shrd rax x 2) ; high bits from rdx (inst sar x 2) ; now shift rdx too (move rcx x) ; save high bits from cdq (inst cdq) ; rdx:eax <- sign-extend of rax (inst cmp x rcx) (inst jmp :e SINGLE-WORD-BIGNUM) (with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2) r11) (storew rax res bignum-digits-offset other-pointer-type) (storew rcx res (1+ bignum-digits-offset) other-pointer-type)) (inst jmp DONE) SINGLE-WORD-BIGNUM (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) r11) (storew rax res bignum-digits-offset other-pointer-type)) (inst jmp DONE) OKAY (move res rax) DONE) (define-assembly-routine (generic-negate (:cost 10) (:return-style :full-call) (:policy :safe) (:translate %negate) (:save-p t)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:res res (descriptor-reg any-reg) rdx-offset) (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset) (:temp r11 unsigned-reg r11-offset)) (inst test x 3) (inst jmp :z FIXNUM) (inst pop rax) (inst push rbp-tn) (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes)) (inst sub rsp-tn (fixnumize 2)) (inst push rax) (inst mov rcx (fixnumize 1)) ; arg count (inst mov rax (+ nil-value (static-function-offset '%negate))) (inst jmp (make-ea :qword :base rax)) FIXNUM (move res x) (inst neg res) ; (- most-negative-fixnum) is BIGNUM (inst jmp :no OKAY) (inst shr res 2) ; sign bit is data - remove type bits (move rcx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset) r11) (storew rcx res bignum-digits-offset other-pointer-type)) OKAY) ;;;; Comparison routines. (eval-when (compile eval) (defmacro define-cond-assem-rtn (name translate static-fn test) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) rdi-offset) (:res res descriptor-reg rdx-offset) (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) (inst test x 3) (inst jmp :nz DO-STATIC-FN) (inst test y 3) (inst jmp :z DO-COMPARE) DO-STATIC-FN (inst pop rax) (inst push rbp-tn) (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes)) (inst sub rsp-tn (* 2 word-bytes)) (inst push rax) (inst mov rcx (fixnumize 2)) (inst mov rax (+ nil-value (static-function-offset ',static-fn))) (inst jmp (make-ea :qword :base rax)) DO-COMPARE (inst cmp x y) (inst jmp ,test TRUE) (inst mov res nil-value) (inst pop rax) (inst add rax 3) ; single value return (inst jmp rax) TRUE (load-symbol res t))) ); eval-when (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) rdi-offset) (:res res descriptor-reg rdx-offset) (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 3) (inst jmp :z RETURN-NIL) (inst test y 3) (inst jmp :nz DO-STATIC-FN) RETURN-NIL (inst mov res nil-value) (inst pop rax) (inst add rax 3) ; single value return (inst jmp rax) DO-STATIC-FN (inst pop rax) (inst push rbp-tn) (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes)) (inst sub rsp-tn (fixnumize 2)) (inst push rax) ; return address (inst mov rcx (fixnumize 2)) ; number of arguments (inst mov rax (+ nil-value (static-function-offset 'eql))) (inst jmp (make-ea :qword :base rax)) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) rdi-offset) (:res res descriptor-reg rdx-offset) (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset) ) (inst test x 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) ; yes do it here (inst test y 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) (inst cmp x y) (inst jmp :e RETURN-T) ; ok (inst mov res nil-value) (inst pop rax) (inst add rax 3) (inst jmp rax) DO-STATIC-FN (inst pop rax) (inst push rbp-tn) (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp word-bytes)) (inst sub rsp-tn (* 2 word-bytes)) (inst push rax) (inst mov rcx (fixnumize 2)) (inst mov rax (+ nil-value (static-function-offset 'two-arg-=))) (inst jmp (make-ea :qword :base rax)) RETURN-T (load-symbol res t)) ;;; Support for the Mersenne Twister, MT19937, random number generator ;;; due to Matsumoto and Nishimura. ;;; ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A ;;; 623-dimensionally equidistributed uniform pseudorandom number ;;; generator.", ACM Transactions on Modeling and Computer Simulation, ;;; 1997, to appear. ;;; ;;; State: ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) ;;; 2: Index; init. to 1. ;;; 3-626: State. ;;; ;;; This assembly routine is called from the inline VOP and updates ;;; the state vector with new random numbers. The state vector is ;;; passed in the rAX register. ;;; #+assembler ; we don't want a vop for this one. (define-assembly-routine (random-mt19937-update) ((:temp state unsigned-reg rax-offset) (:temp k unsigned-reg rbx-offset) (:temp y unsigned-reg rcx-offset) (:temp tmp unsigned-reg rdx-offset)) ;; Save the temporary registers. (inst push k) (inst push y) (inst push tmp) ;; Generate a new set of results. (inst xor k k) LOOP1 (inst mov y (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 1 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip1) (inst xor y #x9908b0df) SKIP1 (inst xor y (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 397 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) (inst inc k) (inst cmp k (- 624 397)) (inst jmp :b loop1) LOOP2 (inst mov y (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 1 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip2) (inst xor y #x9908b0df) SKIP2 (inst xor y (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ (- 397 624) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :qword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) (inst inc k) (inst cmp k (- 624 1)) (inst jmp :b loop2) (inst mov y (make-ea :qword :base state :disp (- (* (+ (- 624 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :qword :base state :disp (- (* (+ 0 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip3) (inst xor y #x9908b0df) SKIP3 (inst xor y (make-ea :qword :base state :disp (- (* (+ (- 397 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :qword :base state :disp (- (* (+ (- 624 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) ;; Restore the temporary registers and return. (inst pop tmp) (inst pop y) (inst pop k) (inst ret)) cmucl-21a/src/assembly/amd64/array.lisp000066400000000000000000000106541260377556400201170ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/amd64/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains various array operations that are too expensive ;;; (in space) to do inline. ;;; ;;; Written by William Lott. ;;; ;;; Debugged by Paul F. Werkowski -- Spring 1995. ;;; (in-package :amd64) ;;;; Allocation (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type unsigned-reg rax-offset) (:arg length any-reg rbx-offset) (:arg words any-reg rcx-offset) (:temp temp any-reg r11-offset) (:res result descriptor-reg rdx-offset)) ;; compute the number of bytes ;; words is a fixnum (inst lea result (make-ea :byte :base words :index words :disp (+ 15 (* vector-data-offset word-bytes)))) (inst and result (lognot 15)) ; alignment (pseudo-atomic (allocation result result temp) (inst lea result (make-ea :byte :base result :disp other-pointer-type)) (storew type result 0 other-pointer-type) (storew length result vector-length-slot other-pointer-type)) (inst ret)) ;;;; Hash primitives (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg rbx-offset) (:res result any-reg rdx-offset) (:temp length any-reg rdi-offset) (:temp rsi unsigned-reg rsi-offset) (:temp rcx unsigned-reg rcx-offset) (:temp rax unsigned-reg rax-offset)) (declare (ignore result rsi rcx rax)) (loadw length string vector-length-slot other-pointer-type) (inst jmp (make-fixup 'sxhash-simple-substring :assembly-routine))) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg rbx-offset) (:arg length any-reg rdi-offset) (:res result any-reg rdx-offset) (:temp rsi unsigned-reg rsi-offset) (:temp rcx unsigned-reg rcx-offset) (:temp rax unsigned-reg rax-offset)) ;; Compute a pointer to where we are going to be extracting the bits. (inst lea rsi (make-ea :byte :base string :disp (- (* vector-data-offset word-bytes) other-pointer-type))) ;; Initialize the result. (inst xor result result) ;; Get the count. If it's zero, blow out. (inst mov rcx length) (inst jrcxz done) ;; Convert it into count of the number of full words. If zero, then skip ;; to the part that handles the tail. (inst shr rcx 5) ; 2 tag bits + 3 (inst jrcxz do-extra) ;; Clear the direction flag, so we advance through memory. (inst cld) LOOP ;; Merge each successive word with the result. (inst lods rax) ; load 64-bits into rax and (+8 rsi) (inst rol result 5) (inst xor result rax) (inst loop loop) DO-EXTRA ;; Now we have to take care of any bytes that don't make up a full word. ;; First, check to see how many of them there are. If zero, blow out of ;; here. Otherwise, multiply by 8. (inst mov rcx length) (inst and rcx (fixnumize 7)) (inst jrcxz done) ;; some bytes are left (inst shl rcx 1) ;; Grab the last word. (inst lods rax) ;; Convert the count into a mask. The count is multiplied by 8, so we just ;; shift -1 left, which shifts count*8 zeros into the low order end. We ;; then invert that, ending up with a mask of count*8 ones. (inst mov rsi -1) (inst shl rsi :cl) (inst not rsi) ;; Use the mask to strip off the bits we arn't interested in, and merge ;; the remaining bits with the result. (inst and rax rsi) (inst rol result 5) (inst xor result rax) DONE ;; Force result to be a 32-bit positive fixnum because hash-vector is a ;; 32-bit vector. This hash function is not good. We need to use the ;; upper half of the word and change the hash-vector. (inst and result #x7ffffffc) (inst ret)) cmucl-21a/src/assembly/amd64/assem-rtns.lisp000066400000000000000000000207541260377556400210770ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/amd64/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; ;;; Written by William Lott ;;; ;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995. ;;; Enhancements/debugging by Douglas T. Crosher 1997. ;;; (in-package :amd64) ;;;; Return-multiple ;;; For return-multiple, we have to move the results from the end of the ;;; frame for the function that is returning to the end of the frame for ;;; the function being returned to. #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) (;; These four are really arguments. (:temp rax unsigned-reg rax-offset) ; the return-pc to finally jump to. (:temp rbx unsigned-reg rbx-offset) ; pointer to where to put the values. (:temp rcx unsigned-reg rcx-offset) ; number of values to find there. (:temp rsi unsigned-reg rsi-offset) ; pointer to where to find the values. ;; These we need as temporaries. (:temp rdx unsigned-reg rdx-offset) (:temp rdi unsigned-reg rdi-offset)) ;; Pick off the cases where everything fits in register args. (inst jrcxz zero-values) (inst cmp rcx (fixnumize 1)) (inst jmp :e one-value) (inst cmp rcx (fixnumize 2)) (inst jmp :e two-values) (inst cmp rcx (fixnumize 3)) (inst jmp :e three-values) ;; Save the count, because the loop is going to destroy it. (inst mov rdx rcx) ;; Blit the values down the stack. Note: there might be overlap, so we have ;; to be careful not to clobber values before we've read them. Because the ;; stack builds down, we are copying to a larger address. Therefore, we need ;; to iterate from larger addresses to smaller addresses. ;; pfw-this says copy rcx words from rsi to rdi counting down. (inst shr rcx 2) ; fixnum to raw word count (inst std) ; count down (inst sub rsi 8) ; ? (inst lea rdi (make-ea :qword :base rbx :disp (- word-bytes))) (inst rep) (inst movs :qword) ;; Restore the count. (inst mov rcx rdx) ;; Set the stack top to the last result. (inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes)) ;; Load the register args. (loadw rdx rbx -1) (loadw rdi rbx -2) (loadw rsi rbx -3) ;; And back we go. (inst jmp rax) ;; Handle the register arg cases. ZERO-VALUES (move rsp-tn rbx) (inst mov rdx nil-value) (inst mov rdi rdx) (inst mov rsi rdx) (inst jmp rax) ONE-VALUE ; Note: we can get this, because the return-multiple vop ; doesn't check for this case when size > speed. (loadw rdx rsi -1) (inst mov rsp-tn rbx) (inst add rax 3) (inst jmp rax) TWO-VALUES (loadw rdx rsi -1) (loadw rdi rsi -2) (inst mov rsi nil-value) (inst lea rsp-tn (make-ea :qword :base rbx :disp (* -2 word-bytes))) (inst jmp rax) THREE-VALUES (loadw rdx rsi -1) (loadw rdi rsi -2) (loadw rsi rsi -3) (inst lea rsp-tn (make-ea :qword :base rbx :disp (* -3 word-bytes))) (inst jmp rax)) ;;;; tail-call-variable. ;;; For tail-call-variable, we have to copy the arguments from the end of our ;;; stack frame (where args are produced) to the start of our stack frame ;;; (where args are expected). ;;; ;;; We take the function to call in rAX and a pointer to the arguments in ;;; rSI. rBP says the same over the jump, and the old frame pointer is ;;; still saved in the first stack slot. The return-pc is saved in ;;; the second stack slot, so we have to push it to make it look like ;;; we actually called. We also have to compute rCX from the difference ;;; between rSI and the stack top. ;;; #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ((:temp rax unsigned-reg rax-offset) (:temp rbx unsigned-reg rbx-offset) (:temp rcx unsigned-reg rcx-offset) (:temp rdx unsigned-reg rdx-offset) (:temp rdi unsigned-reg rdi-offset) (:temp rsi unsigned-reg rsi-offset)) ;; Calculate NARGS (as a fixnum) (move rcx rsi) (inst sub rcx rsp-tn) (inst shr rcx 1) ;; Check for all the args fitting the the registers. (inst cmp rcx (fixnumize 3)) (inst jmp :le REGISTER-ARGS) ;; Save the OLD-FP and RETURN-PC because the blit is going to trash ;; those stack locations. Save the rCX, because the loop is going ;; to trash it. (pushw rbp-tn -1) (loadw rbx rbp-tn -2) (inst push rcx) ;; Do the blit. Because we are copying from smaller addresses to larger ;; addresses, we have to start at the largest pair and work our way down. (inst shr rcx 2) ; fixnum to raw words (inst std) ; count down (inst lea rdi (make-ea :qword :base rbp-tn :disp (- word-bytes))) (inst sub rsi word-bytes) (inst rep) (inst movs :qword) ;; Load the register arguments carefully. (loadw rdx rbp-tn -1) ;; Restore OLD-FP and rCX. (inst pop rcx) (popw rbp-tn -1) ; overwrites a0 ;; Blow off the stack above the arguments. (inst lea rsp-tn (make-ea :qword :base rdi :disp word-bytes)) ;; remaining register args (loadw rdi rbp-tn -2) (loadw rsi rbp-tn -3) ;; Push the (saved) return-pc so it looks like we just called. (inst push rbx) ;; And jump into the function. (inst jmp (make-ea :byte :base rax :disp (- (* closure-function-slot word-bytes) function-pointer-type))) ;; All the arguments fit in registers, so load them. REGISTER-ARGS (loadw rdx rsi -1) (loadw rdi rsi -2) (loadw rsi rsi -3) ;; Clear most of the stack. (inst lea rsp-tn (make-ea :qword :base rbp-tn :disp (* -3 word-bytes))) ;; Push the return-pc so it looks like we just called. (pushw rbp-tn -2) ;; And away we go. (inst jmp (make-ea :byte :base rax :disp (- (* closure-function-slot word-bytes) function-pointer-type)))) (define-assembly-routine (throw (:return-style :none)) ((:arg target (descriptor-reg any-reg) rdx-offset) (:arg start any-reg rbx-offset) (:arg count any-reg rcx-offset) (:temp catch any-reg rax-offset)) (declare (ignore start count)) (load-symbol-value catch lisp::*current-catch-block*) LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst or catch catch) ; check for NULL pointer (inst jmp :z error)) (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) (inst jmp :e exit) (loadw catch catch catch-block-previous-catch-slot) (inst jmp loop) EXIT ;; Here rAX points to catch block containing symbol pointed to by rDX. (inst jmp (make-fixup 'unwind :assembly-routine))) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:return-style :none) (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) rax-offset) (:arg start (any-reg descriptor-reg) rbx-offset) (:arg count (any-reg descriptor-reg) rcx-offset) (:temp uwp unsigned-reg rsi-offset) (:temp temp unsigned-reg r11-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst or block block) ; check for NULL pointer (inst jmp :z error)) (load-symbol-value uwp lisp::*current-unwind-protect-block*) ;; Does *cuwpb* match value stored in argument cuwp slot? (inst cmp uwp (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) ;; If a match, return to context in arg block. (inst jmp :e do-exit) ;; Not a match - return to *current-unwind-protect-block* context. ;; Important! Must save (and return) the arg 'block' for later use!! (move rdx-tn block) (move block uwp) ;; Set next unwind protect context. (loadw uwp uwp unwind-block-current-uwp-slot) (store-symbol-value uwp lisp::*current-unwind-protect-block* temp) DO-EXIT (loadw rbp-tn block unwind-block-current-cont-slot) ;; Uwp-entry expects some things in known locations so that they can ;; be saved on the stack: the block in rdx-tn; start in rbx-tn; and ;; count in rcx-tn (inst jmp (make-ea :byte :base block :disp (* unwind-block-entry-pc-slot word-bytes)))) cmucl-21a/src/assembly/amd64/support.lisp000066400000000000000000000026661260377556400205210ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/amd64/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; ;;; Written by William Lott. ;;; (in-package :amd64) (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (values `((inst call (make-fixup ',name :assembly-routine))) nil)) (:full-call (values `((note-this-location ,vop :call-site) (inst call (make-fixup ',name :assembly-routine)) (note-this-location ,vop :single-value-return) (move rsp-tn rbx-tn)) '((:save-p :compute-only)))) (:none (values `((inst jmp (make-fixup ',name :assembly-routine))) nil)))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `(inst ret)) (:full-call `( (inst pop rax-tn) (inst add rax-tn 3) ; single value return (inst jmp rax-tn))) (:none))) cmucl-21a/src/assembly/assemfile.lisp000066400000000000000000000152431260377556400200350ustar00rootroot00000000000000;;; -*- Package: C -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/assemfile.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the extra code necessary to feed an entire file of ;;; assembly code to the assembler. ;;; (in-package "C") (export '(define-assembly-routine)) (defvar *do-assembly* nil "If non-NIL, emit assembly code. If NIL, emit VOP templates.") (defvar *lap-output-file* nil "The FASL file currently being output to.") (defvar *assembler-routines* nil "A List of (name . label) for every entry point.") (defun assemble-file (name &key (output-file (make-pathname :defaults name :type "assem")) trace-file) (let* ((*do-assembly* t) (name (pathname name)) (*lap-output-file* (open-fasl-file (pathname output-file) name)) (*assembler-routines* nil) (*load-verbose* nil) (won nil) (*code-segment* nil) (*elsewhere* nil) (*assembly-optimize* nil) (*compiler-trace-output* nil) (*fixups* nil) (*coalesce-constants* t)) (unwind-protect (let ((*features* (cons :assembler (backend-features *backend*)))) (when trace-file (setf *compiler-trace-output* (open (if (eq trace-file t) (make-pathname :defaults name :type "trace") trace-file) :direction :output :if-exists :supersede))) (init-assembler) (load (merge-pathnames name (make-pathname :type "lisp"))) (fasl-dump-cold-load-form `(in-package ,(package-name *package*)) *lap-output-file*) (new-assem:append-segment *code-segment* *elsewhere*) (setf *elsewhere* nil) (let ((length (new-assem:finalize-segment *code-segment*))) (dump-assembler-routines *code-segment* length *fixups* *assembler-routines* *lap-output-file*)) (setq won t)) (new-assem:release-segment *code-segment*) (when *elsewhere* (new-assem:release-segment *elsewhere*)) (when *compiler-trace-output* (close *compiler-trace-output*)) (close-fasl-file *lap-output-file* (not won))) won)) (defstruct (reg-spec (:print-function %print-reg-spec)) (kind :temp :type (member :arg :temp :res)) (name nil :type symbol) (temp nil :type symbol) (scs nil :type (or list symbol)) (offset nil)) (defun %print-reg-spec (spec stream depth) (declare (ignore depth)) (format stream "#" (reg-spec-kind spec) (reg-spec-name spec) (reg-spec-scs spec) (reg-spec-offset spec))) (defun reg-spec-sc (spec) (if (atom (reg-spec-scs spec)) (reg-spec-scs spec) (car (reg-spec-scs spec)))) (defun parse-reg-spec (kind name sc offset) (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset))) (ecase kind (:temp) ((:arg :res) (setf (reg-spec-temp reg) (make-symbol (symbol-name name))))) reg)) (defun emit-assemble (name options regs code) (collect ((decls)) (loop (if (and (consp code) (consp (car code)) (eq (caar code) 'declare)) (decls (pop code)) (return))) `(let (,@(mapcar #'(lambda (reg) `(,(reg-spec-name reg) (make-random-tn :kind :normal :sc (sc-or-lose ',(reg-spec-sc reg)) :offset ,(reg-spec-offset reg)))) regs)) ,@(decls) (new-assem:assemble (*code-segment* ',name) ,name (push (cons ',name ,name) *assembler-routines*) ,@code ,@(generate-return-sequence (or (cadr (assoc :return-style options)) :raw))) (when *compile-print* (format *error-output* "; ~S assembled~%" ',name))))) (defun arg-or-res-spec (reg) `(,(reg-spec-name reg) :scs ,(if (atom (reg-spec-scs reg)) (list (reg-spec-scs reg)) (reg-spec-scs reg)) ,@(unless (eq (reg-spec-kind reg) :res) `(:target ,(reg-spec-temp reg))))) (defun emit-vop (name options vars) (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq)) (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq)) (results (remove :res vars :key #'reg-spec-kind :test-not #'eq)) (return-style (or (cadr (assoc :return-style options)) :raw)) (cost (or (cadr (assoc :cost options)) 247)) (vop (make-symbol "VOP"))) (unless (member return-style '(:raw :full-call :none)) (error "Unknown return-style for ~S: ~S" name return-style)) (multiple-value-bind (call-sequence call-temps) (let ((*backend* *target-backend*)) (generate-call-sequence name return-style vop)) `(define-vop ,(if (atom name) (list name) name) (:args ,@(mapcar #'arg-or-res-spec args)) ,@(let ((index -1)) (mapcar #'(lambda (arg) `(:temporary (:sc ,(reg-spec-sc arg) :offset ,(reg-spec-offset arg) :from (:argument ,(incf index)) :to (:eval 2)) ,(reg-spec-temp arg))) args)) ,@(mapcar #'(lambda (temp) `(:temporary (:sc ,(reg-spec-sc temp) :offset ,(reg-spec-offset temp) :from (:eval 1) :to (:eval 3)) ,(reg-spec-name temp))) temps) ,@call-temps (:vop-var ,vop) ,@(let ((index -1)) (mapcar #'(lambda (res) `(:temporary (:sc ,(reg-spec-sc res) :offset ,(reg-spec-offset res) :from (:eval 2) :to (:result ,(incf index)) :target ,(reg-spec-name res)) ,(reg-spec-temp res))) results)) (:results ,@(mapcar #'arg-or-res-spec results)) (:ignore ,@(mapcar #'reg-spec-name temps) ,@(apply #'append (mapcar #'cdr (remove :ignore call-temps :test-not #'eq :key #'car)))) ,@(remove-if #'(lambda (x) (member x '(:return-style :cost))) options :key #'car) (:generator ,cost ,@(mapcar #'(lambda (arg) (if (or (target-featurep :hppa) (target-featurep :alpha)) `(move ,(reg-spec-name arg) ,(reg-spec-temp arg)) `(move ,(reg-spec-temp arg) ,(reg-spec-name arg)))) args) ,@call-sequence ,@(mapcar #'(lambda (res) (if (or (target-featurep :hppa) (target-featurep :alpha)) `(move ,(reg-spec-temp res) ,(reg-spec-name res)) `(move ,(reg-spec-name res) ,(reg-spec-temp res)))) results)))))) (defmacro define-assembly-routine (name&options vars &rest code) (multiple-value-bind (name options) (if (atom name&options) (values name&options nil) (values (car name&options) (cdr name&options))) (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars))) (if *do-assembly* (emit-assemble name options regs code) (emit-vop name options regs))))) cmucl-21a/src/assembly/hppa/000077500000000000000000000000001260377556400161175ustar00rootroot00000000000000cmucl-21a/src/assembly/hppa/alloc.lisp000066400000000000000000000012741260377556400201060ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/hppa/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocation of stuff we don't want to do inline. ;;; ;;; Written by William Lott. ;;; (in-package "HPPA") ;;; Given that the pseudo-atomic sequence is so short, there is ;;; nothing that qualifies. But we want to keep the file around ;;; in case we decide to add something later. cmucl-21a/src/assembly/hppa/arith.lisp000066400000000000000000000164171260377556400201300ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/hppa/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; (in-package "HPPA") ;;;; Multiplication and Division helping routines. #+assembler (define-assembly-routine multiply ((:arg x (signed-reg) nl0-offset) (:arg y (signed-reg) nl1-offset) (:res res (signed-reg) nl2-offset) (:temp tmp (unsigned-reg) nl3-offset) (:temp sign (unsigned-reg) nl4-offset)) ;; Determine the sign of the result. (inst extrs x 0 1 sign :=) (inst sub zero-tn x x) (inst extrs y 0 1 tmp :=) (inst sub zero-tn y y) (inst xor sign tmp sign) ;; Make sure X is less then Y. (inst comclr x y tmp :<<) (inst xor x y tmp) (inst xor x tmp x) (inst xor y tmp y) ;; Blow out of here if the result is zero. (inst comb := x zero-tn done) (inst li 0 res) LOOP (inst extru x 31 1 zero-tn :ev) (inst add y res res) (inst extru x 30 1 zero-tn :ev) (inst sh1add y res res) (inst extru x 29 1 zero-tn :ev) (inst sh2add y res res) (inst extru x 28 1 zero-tn :ev) (inst sh3add y res res) (inst srl x 4 x) (inst comb :<> x zero-tn loop) (inst sll y 4 y) DONE (inst xor res sign res) (inst add res sign res)) #+assembler (define-assembly-routine (truncate) ((:arg dividend signed-reg nl0-offset) (:arg divisor signed-reg nl1-offset) (:res quo signed-reg nl2-offset) (:res rem signed-reg nl3-offset)) ;; Move abs(divident) into quo. (inst move dividend quo :>=) (inst sub zero-tn quo quo) ;; Do one divide-step with -divisor to prime V (use rem as a temp) (inst sub zero-tn divisor rem) (inst ds zero-tn rem zero-tn) ;; Shift the dividend/quotient one bit, setting the carry flag. (inst add quo quo quo) ;; The first real divide-step. (inst ds zero-tn divisor rem) (inst addc quo quo quo) ;; And 31 more of them. (dotimes (i 31) (inst ds rem divisor rem) (inst addc quo quo quo)) ;; If the remainder is negative, we need to add the absolute value of the ;; divisor. (inst comb :>= rem zero-tn remainder-positive) (inst comclr divisor zero-tn zero-tn :<) (inst add rem divisor rem :tr) (inst sub rem divisor rem) REMAINDER-POSITIVE ;; Now we have to fix the signs of quo and rem. (inst xor divisor dividend zero-tn :>=) (inst sub zero-tn quo quo) (inst move dividend zero-tn :>=) (inst sub zero-tn rem rem)) ;;;; Generic arithmetic. (define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst extru x 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst extru y 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst addo x y res) (lisp-return lra :offset 1) DO-STATIC-FUN (inst ldw (static-function-offset 'two-arg-+) null-tn lip) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst bv lip) (inst move csp-tn cfp-tn)) (define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst extru x 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst extru y 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst subo x y res) (lisp-return lra :offset 1) DO-STATIC-FUN (inst ldw (static-function-offset 'two-arg--) null-tn lip) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst bv lip) (inst move csp-tn cfp-tn)) ;;;; Comparison routines. (macrolet ((define-cond-assem-rtn (name translate static-fn cond) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst extru x 31 2 zero-tn :=) (inst b do-static-fn :nullify t) (inst extru y 31 2 zero-tn :=) (inst b do-static-fn :nullify t) (inst comclr x y zero-tn ,cond) (inst move null-tn res :tr) (load-symbol res t) (lisp-return lra :offset 1) DO-STATIC-FN (inst ldw (static-function-offset ',static-fn) null-tn lip) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst bv lip) (inst move csp-tn cfp-tn)))) (define-cond-assem-rtn generic-< < two-arg-< :<) (define-cond-assem-rtn generic-> > two-arg-> :>)) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst comb := x y return-t :nullify t) (inst extru x 31 2 zero-tn :<>) (inst b return-nil :nullify t) (inst extru y 31 2 zero-tn :=) (inst b do-static-fn :nullify t) RETURN-NIL (inst move null-tn res) (lisp-return lra :offset 1) DO-STATIC-FN (inst ldw (static-function-offset 'eql) null-tn lip) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst bv lip) (inst move csp-tn cfp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst comb := x y return-t :nullify t) (inst extru x 31 2 zero-tn :=) (inst b do-static-fn :nullify t) (inst extru y 31 2 zero-tn :=) (inst b do-static-fn :nullify t) (inst move null-tn res) (lisp-return lra :offset 1) DO-STATIC-FN (inst ldw (static-function-offset 'two-arg-=) null-tn lip) (inst li (fixnumize 2) nargs) (inst move cfp-tn ocfp) (inst bv lip) (inst move csp-tn cfp-tn) RETURN-T (load-symbol res t)) cmucl-21a/src/assembly/hppa/array.lisp000066400000000000000000000062251260377556400201330ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/hppa/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; (in-package "HPPA") (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp vector descriptor-reg a3-offset)) (pseudo-atomic () (move alloc-tn vector) (inst dep other-pointer-type 31 3 vector) (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr) (inst dep 0 31 3 ndescr) (inst add ndescr alloc-tn alloc-tn) (inst srl type word-shift ndescr) (storew ndescr vector 0 other-pointer-type) (storew length vector vector-length-slot other-pointer-type)) (move vector result)) ;;;; Hash primitives #+assembler (defparameter *sxhash-simple-substring-entry* (gen-label)) (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp offset non-descriptor-reg nl2-offset)) (declare (ignore result accum data offset)) ;; Save the return address. (inst b *sxhash-simple-substring-entry*) (loadw length string vector-length-slot other-pointer-type)) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp offset non-descriptor-reg nl2-offset)) (emit-label *sxhash-simple-substring-entry*) (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset) (inst b test) (move zero-tn accum) LOOP (inst xor accum data accum) (inst shd accum accum 5 accum) TEST (inst ldwx offset string data) (inst addib :>= (fixnumize -4) length loop) (inst addi (fixnumize 1) offset offset) (inst addi (fixnumize 4) length length) (inst comb := zero-tn length done :nullify t) (inst sub zero-tn length length) (inst sll length 1 length) (inst mtctl length :sar) (inst shd zero-tn data :variable data) (inst xor accum data accum) DONE (inst sll accum 5 result) (inst srl result 3 result)) cmucl-21a/src/assembly/hppa/assem-rtns.lisp000066400000000000000000000142251260377556400211100ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/hppa/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains a handful of random assembly routines. ;;; ;;; Written by William Lott. ;;; (in-package "HPPA") ;;;; Return-multiple with other than one value #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) (:temp old-fp any-reg nl1-offset) (:temp lra descriptor-reg lra-offset) ;; These are just needed to facilitate the transfer (:temp count any-reg nl2-offset) (:temp src any-reg nl3-offset) (:temp dst any-reg nl4-offset) (:temp temp descriptor-reg l0-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) (inst movb := nvals count default-a0-and-on :nullify t) (loadw a0 vals 0) (inst addib := (fixnumize -1) count default-a1-and-on :nullify t) (loadw a1 vals 1) (inst addib := (fixnumize -1) count default-a2-and-on :nullify t) (loadw a2 vals 2) (inst addib := (fixnumize -1) count default-a3-and-on :nullify t) (loadw a3 vals 3) (inst addib := (fixnumize -1) count default-a4-and-on :nullify t) (loadw a4 vals 4) (inst addib := (fixnumize -1) count default-a5-and-on :nullify t) (loadw a5 vals 5) (inst addib := (fixnumize -1) count done :nullify t) ;; Copy the remaining args to the top of the stack. (inst addi (* 6 word-bytes) vals src) (inst addi (* 6 word-bytes) cfp-tn dst) LOOP (inst ldwm 4 src temp) (inst addib :> (fixnumize -1) count loop) (inst stwm temp 4 dst) (inst b done :nullify t) DEFAULT-A0-AND-ON (inst move null-tn a0) DEFAULT-A1-AND-ON (inst move null-tn a1) DEFAULT-A2-AND-ON (inst move null-tn a2) DEFAULT-A3-AND-ON (inst move null-tn a3) DEFAULT-A4-AND-ON (inst move null-tn a4) DEFAULT-A5-AND-ON (inst move null-tn a5) DONE ;; Clear the stack. (move cfp-tn ocfp-tn) (move old-fp cfp-tn) (inst add ocfp-tn nvals csp-tn) ;; Return. (lisp-return lra)) ;;;; tail-call-variable. #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) (:temp lexenv descriptor-reg lexenv-offset) ;; We need to compute this (:temp nargs any-reg nargs-offset) ;; These are needed by the blitting code. (:temp src any-reg nl1-offset) (:temp dst any-reg nl2-offset) (:temp count any-reg nl3-offset) (:temp temp descriptor-reg l0-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Calculate NARGS (as a fixnum) (inst sub csp-tn args nargs) ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (loadw a0 args 0) (loadw a1 args 1) (loadw a2 args 2) (loadw a3 args 3) (loadw a4 args 4) (loadw a5 args 5) ;; Calc SRC, DST, and COUNT (inst addi (fixnumize (- register-arg-count)) nargs count) (inst comb :<= count zero-tn done :nullify t) (inst addi (* word-bytes register-arg-count) args src) (inst addi (* word-bytes register-arg-count) cfp-tn dst) LOOP ;; Copy one arg. (inst ldwm 4 src temp) (inst addib :> (fixnumize -1) count loop) (inst stwm temp 4 dst) DONE ;; We are done. Do the jump. (loadw temp lexenv closure-function-slot function-pointer-type) (lisp-jump temp)) ;;;; Non-local exit noise. #+assembler (defparameter *unwind-entry-point* (gen-label)) (define-assembly-routine (unwind (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) a0-offset) (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lra descriptor-reg lra-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (emit-label *unwind-entry-point*) (let ((error (generate-error-code nil invalid-unwind-error))) (inst bc := nil block zero-tn error)) (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) (loadw target-uwp block unwind-block-current-uwp-slot) (inst bc :<> nil cur-uwp target-uwp do-uwp) (move block cur-uwp) DO-EXIT (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) (lisp-return lra :frob-code nil) DO-UWP (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) (inst b do-exit) (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) (define-assembly-routine throw ((:arg target descriptor-reg a0-offset) (:arg start any-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset)) (declare (ignore start count)) ; We just need them in the registers. (load-symbol-value catch lisp::*current-catch-block*) LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst bc := nil catch zero-tn error)) (loadw tag catch catch-block-tag-slot) (inst comb :<> tag target loop :nullify t) (loadw catch catch catch-block-previous-catch-slot) (inst b *unwind-entry-point*) (inst move catch target)) cmucl-21a/src/assembly/hppa/support.lisp000066400000000000000000000050261260377556400205270ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/hppa/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; ;;; Written by William Lott. ;;; (in-package "HPPA") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (let ((fixup (gensym "FIXUP-"))) (values `((let ((fixup (make-fixup ',name :assembly-routine))) (inst ldil fixup ,fixup) (inst ble fixup lisp-heap-space ,fixup :nullify t)) (inst nop)) `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) ,fixup))))) (:full-call (let ((temp (make-symbol "TEMP")) (nfp-save (make-symbol "NFP-SAVE")) (lra (make-symbol "LRA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn ,nfp-save cur-nfp)) (inst compute-lra-from-code code-tn lra-label ,temp ,lra) (note-this-location ,vop :call-site) (let ((fixup (make-fixup ',name :assembly-routine))) (inst ldil fixup ,temp) (inst be fixup lisp-heap-space ,temp :nullify t)) (emit-return-pc lra-label) (note-this-location ,vop :single-value-return) (move ocfp-tn csp-tn) (inst compute-code-from-lra code-tn lra-label ,temp code-tn) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save) (:save-p :compute-only))))) (:none (let ((fixup (gensym "FIXUP-"))) (values `((let ((fixup (make-fixup ',name :assembly-routine))) (inst ldil fixup ,fixup) (inst be fixup lisp-heap-space ,fixup :nullify t))) `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) ,fixup))))))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst bv lip-tn :nullify t))) (:full-call `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg) :offset lra-offset) :offset 1))) (:none))) cmucl-21a/src/assembly/mips/000077500000000000000000000000001260377556400161375ustar00rootroot00000000000000cmucl-21a/src/assembly/mips/alloc.lisp000066400000000000000000000116271260377556400201310ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocating simple objects. ;;; ;;; Written by William Lott. ;;; (in-package "MIPS") #+gengc (progn #+assembler (defparameter large-alloc-entry (gen-label)) #+assembler (define-assembly-routine var-alloc ((:arg lowtag unsigned-reg nl0-offset) (:arg header unsigned-reg nl1-offset) (:arg words any-reg nargs-offset) (:temp ndescr non-descriptor-reg nl2-offset) (:res result descriptor-reg a0-offset)) ;; Is it a large object? (inst slt ndescr words (1+ (fixnumize large-object-cutoff))) (inst beq ndescr large-alloc-entry) (inst nop) ;; Round words up to a dual-word. This is kinda sleazy, changing words like ;; this. But we can because the vop thinks it is temporary. (inst addu words (+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes))) (inst li ndescr (lognot lowtag-mask)) (inst and words ndescr) ;; And allocate it in the nursery. (without-scheduling () (inst or result alloc-tn lowtag) (inst sw header alloc-tn) (inst addu alloc-tn alloc-tn words))) (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type unsigned-reg nl1-offset) (:arg length any-reg nl2-offset) (:arg words any-reg nargs-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp cfunc unsigned-reg cfunc-offset) (:temp nl4 unsigned-reg nl4-offset) (:res result descriptor-reg a0-offset)) (progn cfunc nl4) ; ignore em ;; Add in space for the header word and length. (inst addu words (* vector-data-offset word-bytes)) ;; Is it a large object? (inst slt ndescr words (1+ (fixnumize large-object-cutoff))) (inst beq ndescr large-alloc-entry) ;; Load ndescr with other-pointer-type because if we take the branch, we ;; need nl0 loaded with the desired lowtag. (inst li ndescr other-pointer-type) ;; Round words up to a dual-word. This is kinda sleezy, changing words like ;; this. But we can because the vop thinks it is temporary. (inst addu words (1- (ash 1 lowtag-bits))) (inst li ndescr (lognot lowtag-mask)) (inst and words ndescr) ;; And allocate it. (without-scheduling () (inst or result alloc-tn other-pointer-type) (storew type alloc-tn) (storew length alloc-tn vector-length-slot) (inst addu alloc-tn words))) #+assembler (defmacro with-regs-saved ((&rest regs) &body body) (let ((stack-space-needed (* (logandc2 (1+ (length regs)) 1) word-bytes)) (sc-var (gensym "DESCRIPTOR-REG-SC-"))) `(let ((,sc-var (sc-or-lose 'descriptor-reg))) (inst addu csp-tn ,stack-space-needed) ,(iterate repeat ((remaining regs) (offset (- word-bytes))) (if remaining (let* ((reg (car remaining)) (tn-var (gensym (concatenate 'string (symbol-name reg) "-TN-"))) (reg-offset (symbolicate reg "-OFFSET"))) `(let ((,tn-var (make-random-tn :kind :normal :sc ,sc-var :offset ,reg-offset))) (inst sw ,tn-var csp-tn ,offset) ,(repeat (cdr remaining) (- offset word-bytes)) (inst lw ,tn-var csp-tn ,offset))) `(progn ,@body))) (inst subu csp-tn ,stack-space-needed)))) (define-assembly-routine (large-alloc (:info name) (:ignore name nl4 temp)) ((:arg words any-reg nargs-offset) (:arg lowtag unsigned-reg nl0-offset) (:arg header any-reg nl1-offset) (:arg next-word any-reg nl2-offset) (:temp temp unsigned-reg cfunc-offset) (:temp nl4 unsigned-reg nl4-offset) (:res result descriptor-reg a0-offset)) (progn words lowtag header next-word nl4) ;; var-alloc and allocate-vector jump to here if the result is going to ;; be large. (emit-label large-alloc-entry) ;; Disable interrupts. (loadw temp mutator-tn mutator-interrupts-disabled-count-slot) (inst addu temp temp 1) (storew temp mutator-tn mutator-interrupts-disabled-count-slot) (with-regs-saved (a1 a2 a3 a4 a5 fdefn lexenv ra) (inst li temp (make-fixup "allocate_large_object" :foreign)) (inst jal (make-fixup "call_into_c" :foreign)) (inst nop)) (inst move result temp) ;; Re-enable interrupts. (loadw temp mutator-tn mutator-interrupts-disabled-count-slot) (inst subu temp temp 1) (inst bne temp zero-tn done) (storew temp mutator-tn mutator-interrupts-disabled-count-slot) ;; Check to see if any are pending. (loadw temp mutator-tn mutator-interrupt-pending-slot) (inst beq temp zero-tn done) (inst nop) (inst break pending-interrupt-trap) DONE) ); #+gengc progn cmucl-21a/src/assembly/mips/arith.lisp000066400000000000000000000235631260377556400201500ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; (in-package "MIPS") (define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and temp x 3) (inst bne temp DO-STATIC-FUN) (inst and temp y 3) (inst bne temp DO-STATIC-FUN) (inst nop) (inst add res x y) #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lw lip null-tn (static-function-offset 'two-arg-+)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn)) (define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and temp x 3) (inst bne temp DO-STATIC-FUN) (inst and temp y 3) (inst bne temp DO-STATIC-FUN) (inst nop) (inst sub res x y) #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lw lip null-tn (static-function-offset 'two-arg--)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn)) (define-assembly-routine (generic-* (:cost 25) (:return-style :full-call) (:translate *) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) #-gengc (:temp pa-flag non-descriptor-reg nl4-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst and temp x 3) (inst bne temp DO-STATIC-FUN) (inst and temp y 3) (inst bne temp DO-STATIC-FUN) (inst nop) ;; Remove the tag from one arg so that the result will have the correct ;; fixnum tag. (inst sra temp x 2) (inst mult temp y) (inst mflo res) (inst mfhi hi) ;; Check to see if the result will fit in a fixnum. (I.e. the high word ;; is just 32 copies of the sign bit of the low word). (inst sra temp res 31) (inst xor temp hi) (inst beq temp DONE) ;; Shift the double word hi:res down two bits into hi:low to get rid of the ;; fixnum tag. (inst srl lo res 2) (inst sll temp hi 30) (inst or lo temp) (inst sra hi 2) ;; Do we need one word or two? Assume two. (inst sra temp lo 31) (inst xor temp hi) (inst bne temp two-words) ;; Assume a two word header. (inst li temp (logior (ash 2 type-bits) bignum-type)) ;; Only need one word, fix the header. (inst li temp (logior (ash 1 type-bits) bignum-type)) #-gengc (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset))) (inst or res alloc-tn other-pointer-type) (storew temp res 0 other-pointer-type)) #+gengc (without-scheduling () (inst or res alloc-tn other-pointer-type) (storew temp alloc-tn) (inst addu alloc-tn (pad-data-block (+ 1 bignum-digits-offset)))) (storew lo res bignum-digits-offset other-pointer-type) ;; Out of here #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) TWO-WORDS #-gengc (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset))) (inst or res alloc-tn other-pointer-type) (storew temp res 0 other-pointer-type)) #+gengc (without-scheduling () (inst or res alloc-tn other-pointer-type) (storew temp alloc-tn) (inst addu alloc-tn (pad-data-block (+ 2 bignum-digits-offset)))) (storew lo res bignum-digits-offset other-pointer-type) (storew hi res (1+ bignum-digits-offset) other-pointer-type) ;; Out of here #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lw lip null-tn (static-function-offset 'two-arg-*)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) DONE) ;;;; Comparison routines. (macrolet ((define-cond-assem-rtn (name translate static-fn cmp not-p) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and temp x 3) (inst bne temp DO-STATIC-FN) (inst and temp y 3) (inst beq temp DO-COMPARE) ,cmp DO-STATIC-FN (inst lw lip null-tn (static-function-offset ',static-fn)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) DO-COMPARE (inst ,(if not-p 'bne 'beq) temp done) (inst move res null-tn) (load-symbol res t) DONE))) (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil) (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil)) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst beq x y RETURN-T) (inst and temp x 3) (inst beq temp RETURN-NIL) (inst and temp y 3) (inst bne temp DO-STATIC-FN) (inst nop) RETURN-NIL (inst move res null-tn) #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lw lip null-tn (static-function-offset 'eql)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and temp x 3) (inst bne temp DO-STATIC-FN) (inst and temp y 3) (inst bne temp DO-STATIC-FN) (inst nop) (inst beq x y RETURN-T) (inst move res null-tn) #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lw lip null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-/= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate /=) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra any-reg ra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst and temp x 3) (inst bne temp DO-STATIC-FN) (inst and temp y 3) (inst bne temp DO-STATIC-FN) (inst nop) (inst beq x y RETURN-NIL) (load-symbol res t) #+gengc (progn (inst addu lip ra (* 2 word-bytes)) (inst j lip) (inst nop)) #-gengc (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lw lip null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j lip) (inst move cfp-tn csp-tn) RETURN-NIL (inst move res null-tn)) cmucl-21a/src/assembly/mips/array.lisp000066400000000000000000000113771260377556400201570ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; (in-package "MIPS") #-gengc (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp pa-flag non-descriptor-reg nl4-offset)) ;; This is kinda sleazy, changing words like this. But we can because ;; the vop thinks it is temporary. (inst addu words (+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes))) (inst li ndescr (lognot lowtag-mask)) (inst and words ndescr) (inst srl ndescr type word-shift) (pseudo-atomic (pa-flag) (inst or result alloc-tn other-pointer-type) (inst addu alloc-tn words) (storew ndescr result 0 other-pointer-type) (storew length result vector-length-slot other-pointer-type))) ;;;; Hash primitives (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp lip interior-reg lip-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp byte non-descriptor-reg nl2-offset) #-gengc (:temp retaddr non-descriptor-reg nl3-offset)) ;; These are needed after we jump into sxhash-simple-substring. (progn result lip accum data byte #-gengc retaddr) (inst j (make-fixup 'sxhash-simple-substring :assembly-routine)) (loadw length string vector-length-slot other-pointer-type)) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp byte non-descriptor-reg nl2-offset) #-gengc (:temp retaddr non-descriptor-reg nl3-offset)) ;; Save the return address #-gengc (inst subu retaddr lip code-tn) ;; Get a pointer to the data. (inst addu lip string (- (* vector-data-offset word-bytes) other-pointer-type)) (inst b test) (move accum zero-tn) loop (inst and byte data #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) (inst srl byte data 8) (inst and byte byte #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) (inst srl byte data 16) (inst and byte byte #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) (inst srl byte data 24) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) (inst addu lip lip 4) test (inst addu length length (fixnumize -4)) (inst lw data lip 0) (inst bgez length loop) (inst nop) (inst addu length length (fixnumize 3)) (inst beq length zero-tn one-more) (inst addu length length (fixnumize -1)) (inst beq length zero-tn two-more) (inst addu length length (fixnumize -1)) (inst bne length zero-tn done) (inst nop) #+sgi (inst srl byte data 8) #+pmax (inst srl byte data 16) (inst and byte byte #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) two-more #+sgi (inst srl byte data 16) #+pmax (inst srl byte data 8) (inst and byte byte #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) one-more #+sgi (inst srl data data 24) (inst and byte data #xff) (inst xor accum accum byte) (inst sll byte accum 5) (inst srl accum accum 27) (inst or accum accum byte) done (inst sll result accum 5) (inst srl result result 3) ;; Restore the return address. #-gengc (inst addu lip code-tn retaddr)) cmucl-21a/src/assembly/mips/assem-rtns.lisp000066400000000000000000000164471260377556400211400ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "MIPS") ;;;; Return-multiple with other than one value #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) (:temp ocfp any-reg nl1-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp ra descriptor-reg ra-offset) ;; These are just needed to facilitate the transfer #-gengc (:temp lip interior-reg lip-offset) (:temp count any-reg nl2-offset) (:temp dst any-reg nl4-offset) (:temp temp descriptor-reg l0-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Note, because of the way the return-multiple vop is written, we can ;; assume that we are never called with nvals == 1 and that a0 has already ;; been loaded. (inst blez nvals default-a0-and-on) (inst subu count nvals (fixnumize 2)) (inst blez count default-a2-and-on) (inst lw a1 vals (* 1 vm:word-bytes)) (inst subu count (fixnumize 1)) (inst blez count default-a3-and-on) (inst lw a2 vals (* 2 vm:word-bytes)) (inst subu count (fixnumize 1)) (inst blez count default-a4-and-on) (inst lw a3 vals (* 3 vm:word-bytes)) (inst subu count (fixnumize 1)) (inst blez count default-a5-and-on) (inst lw a4 vals (* 4 vm:word-bytes)) (inst subu count (fixnumize 1)) (inst blez count done) (inst lw a5 vals (* 5 vm:word-bytes)) ;; Copy the remaining args to the top of the stack. (inst addu vals vals (* 6 vm:word-bytes)) (inst addu dst cfp-tn (* 6 vm:word-bytes)) LOOP (inst lw temp vals) (inst addu vals vm:word-bytes) (inst sw temp dst) (inst subu count (fixnumize 1)) (inst bne count zero-tn loop) (inst addu dst vm:word-bytes) (inst b done) (inst nop) DEFAULT-A0-AND-ON (inst move a0 null-tn) (inst move a1 null-tn) DEFAULT-A2-AND-ON (inst move a2 null-tn) DEFAULT-A3-AND-ON (inst move a3 null-tn) DEFAULT-A4-AND-ON (inst move a4 null-tn) DEFAULT-A5-AND-ON (inst move a5 null-tn) DONE ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst addu csp-tn ocfp-tn nvals) ;; Return. #-gengc (lisp-return lra lip) #+gengc (progn (inst j ra) (inst nop))) ;;;; tail-call-variable. #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) (:temp lexenv descriptor-reg lexenv-offset) ;; We need to compute this (:temp nargs any-reg nargs-offset) ;; These are needed by the blitting code. (:temp src any-reg nl1-offset) (:temp dst any-reg nl2-offset) (:temp count any-reg cfunc-offset) (:temp temp descriptor-reg l0-offset) ;; Needed for the jump (:temp lip interior-reg lip-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Calculate NARGS (as a fixnum) (inst subu nargs csp-tn args) ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst lw a0 args (* 0 vm:word-bytes)) (inst lw a1 args (* 1 vm:word-bytes)) (inst lw a2 args (* 2 vm:word-bytes)) (inst lw a3 args (* 3 vm:word-bytes)) (inst lw a4 args (* 4 vm:word-bytes)) (inst lw a5 args (* 5 vm:word-bytes)) ;; Calc SRC, DST, and COUNT (inst addu count nargs (fixnumize (- register-arg-count))) (inst blez count done) (inst addu src args (* vm:word-bytes register-arg-count)) (inst addu dst cfp-tn (* vm:word-bytes register-arg-count)) LOOP ;; Copy one arg. (inst lw temp src) (inst addu src src vm:word-bytes) (inst sw temp dst) (inst addu count (fixnumize -1)) (inst bgtz count loop) (inst addu dst dst vm:word-bytes) DONE ;; We are done. Do the jump. #-gengc (progn (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) (lisp-jump temp lip)) #+gengc (progn (loadw lip lexenv function-entry-point-slot function-pointer-type) (inst j lip) (inst nop))) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) a0-offset) (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) #-gengc (:temp lip interior-reg lip-offset) #-gengc (:temp lra descriptor-reg lra-offset) #+gengc (:temp temp any-reg l0-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst beq block zero-tn error)) #-gengc (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) #+gengc (loadw cur-uwp mutator-tn mutator-current-unwind-protect-slot) (loadw target-uwp block vm:unwind-block-current-uwp-slot) (inst bne cur-uwp target-uwp do-uwp) (inst nop) (move cur-uwp block) do-exit (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) #-gengc (progn (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) (lisp-return lra lip :frob-code nil)) #+gengc (progn (loadw temp cur-uwp vm:unwind-block-entry-pc-slot) (inst j temp) (inst nop)) do-uwp (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) (inst b do-exit) #-gengc (store-symbol-value next-uwp lisp::*current-unwind-protect-block*) #+gengc (storew next-uwp mutator-tn mutator-current-unwind-protect-slot)) (define-assembly-routine throw ((:arg target descriptor-reg a0-offset) (:arg start any-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset)) (progn start count) ; We just need them in the registers. #-gengc (load-symbol-value catch lisp::*current-catch-block*) #+gengc (loadw catch mutator-tn mutator-current-catch-block-slot) loop (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst beq catch zero-tn error) (inst nop)) (loadw tag catch vm:catch-block-tag-slot) (inst beq tag target exit) (inst nop) (loadw catch catch vm:catch-block-previous-catch-slot) (inst b loop) (inst nop) exit (move target catch) (inst j (make-fixup 'unwind :assembly-routine)) (inst nop)) cmucl-21a/src/assembly/mips/bit-bash.lisp000066400000000000000000000366051260377556400205330ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/bit-bash.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/mips/bit-bash.lisp $ ;;; ;;; Stuff to implement bit bashing. ;;; ;;; Written by William Lott. ;;; (in-package "MIPS") ;;;; Blitting macros. Used only at assemble time. #+assembler (eval-when (compile eval) ;;; The main dispatch. Assumes that the following TNs are bound: ;;; dst, dst-offset -- where to put the stuff. ;;; src, src-offset -- where to get the stuff. ;;; dst-bit-offset, src-bit-offset ;;; length -- the number of bits to move. ;;; temp1, temp2 -- random descriptor temp ;;; ntemp1, ntemp2, ntemp3 -- random non-descriptor temps. (defmacro do-copy () '(let ((wide-copy (gen-label)) (copy-left (gen-label)) (copy-right (gen-label))) (compute-bit/word-offsets src src-offset src-bit-offset) (compute-bit/word-offsets dst dst-offset dst-bit-offset) (inst addu temp1 dst-bit-offset length) (inst subu temp1 (fixnumize 32)) (inst bgez temp1 wide-copy) (inst sltu ntemp1 src dst) (narrow-copy) (emit-label wide-copy) (inst bne ntemp1 copy-right) (inst nop) (inst bne src dst copy-left) (inst sltu ntemp1 src-bit-offset dst-bit-offset) (inst bne ntemp1 copy-right) (inst nop) (inst beq src-bit-offset dst-bit-offset done) (inst nop) (emit-label copy-left) (wide-copy-left) (emit-label copy-right) (wide-copy-right))) (defmacro compute-bit/word-offsets (ptr offset bit) `(progn (inst and ,bit ,offset (fixnumize 31)) (inst sra ntemp1 ,offset 7) (inst sll ntemp1 2) (inst addu ,ptr ntemp1))) (defmacro narrow-copy () '(let ((aligned (gen-label)) (only-one-src-word (gen-label)) (merge-and-write (gen-label))) (inst beq src-bit-offset dst-bit-offset aligned) (inst lw ntemp1 src) ;; It's not aligned, so get the source bits and align them. (inst sra ntemp2 src-bit-offset 2) (inst add temp1 src-bit-offset length) (inst sub temp1 (fixnumize 32)) (inst blez temp1 only-one-src-word) (inst srl ntemp1 ntemp2) (inst lw ntemp3 src 4) (inst subu ntemp2 zero-tn ntemp2) (inst sll ntemp3 ntemp2) (inst or ntemp1 ntemp3) (emit-label only-one-src-word) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 length) (inst lw ntemp3 ntemp3) (inst sra ntemp2 dst-bit-offset 2) (inst and ntemp1 ntemp3) (inst sll ntemp1 ntemp2) (inst b merge-and-write) (inst sll ntemp3 ntemp2) (emit-label aligned) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 length) (inst lw ntemp3 ntemp3) (inst sra ntemp2 dst-bit-offset 2) (inst sll ntemp3 ntemp2) (inst and ntemp1 ntemp3) (emit-label merge-and-write) ;; ntemp1 has the bits we need to deposit, and ntemp3 has the mask. ;; Both are aligned with dst. (inst lw ntemp2 dst) (inst nor ntemp3 ntemp3 zero-tn) (inst and ntemp2 ntemp3) (inst or ntemp1 ntemp2) (inst b done) (inst sw ntemp1 dst))) (defmacro wide-copy-left () '(let ((aligned (gen-label))) ;; Check to see if they are aligned. (inst beq src-bit-offset dst-bit-offset aligned) ;; Calc src-shift (inst subu src-shift dst-offset src-offset) (inst and src-shift (fixnumize 31)) (macrolet ((middle (&rest before-last-inst) `(progn (inst lw ntemp1 src) (inst lw ntemp2 src 4) (inst addu src 4) (inst sra ntemp3 src-shift 2) (inst sll ntemp2 ntemp2 ntemp3) (inst subu ntemp3 zero-tn ntemp3) (inst srl ntemp1 ntemp1 ntemp3) ,@before-last-inst (inst or ntemp1 ntemp2))) (get-src (where) (ecase where (:left '(let ((dont-load (gen-label)) (done-load (gen-label))) (inst sltu ntemp1 src-bit-offset dst-bit-offset) (inst bne ntemp1 dont-load) (middle (inst b done-load)) (emit-label dont-load) (inst sra ntemp3 src-shift 2) (inst sll ntemp1 ntemp3) (emit-label done-load))) (:middle '(middle)) (:right '(let ((dont-load (gen-label)) (done-load (gen-label))) (inst sltu ntemp1 src-shift final-bits) (inst beq ntemp1 dont-load) (middle (inst b done-load)) (emit-label dont-load) (inst sra ntemp3 src-shift 2) (inst subu ntemp3 zero-tn ntemp3) (inst srl ntemp1 ntemp3) (emit-label done-load)))))) (wide-copy-left-aux)) (macrolet ((get-src (where) (declare (ignore where)) '(progn (inst lw ntemp1 src) (inst addu src 4)))) (emit-label aligned) (wide-copy-left-aux)))) (defmacro wide-copy-left-aux () '(let ((left-aligned (gen-label)) (loop (gen-label)) (check-right (gen-label)) (final-bits temp1) (interior temp2)) (inst beq dst-bit-offset left-aligned) (inst nop) (get-src :left) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 dst-bit-offset) (inst lw ntemp3 ntemp3) (inst lw ntemp2 dst) (inst addu dst 4) (inst and ntemp2 ntemp3) (inst nor ntemp3 ntemp3 zero-tn) (inst and ntemp1 ntemp3) (inst or ntemp2 ntemp1) (inst sw ntemp2 dst -4) (emit-label left-aligned) (inst addu final-bits length dst-bit-offset) (inst and final-bits (fixnumize 31)) (inst subu ntemp1 length final-bits) (inst srl ntemp1 7) (inst beq ntemp1 check-right) (inst sll interior ntemp1 2) (emit-label loop) (get-src :middle) (inst sw ntemp1 dst) (check-for-interrupts) (inst subu interior 4) (inst bgtz interior loop) (inst addu dst 4) (emit-label check-right) (inst beq final-bits done) (inst nop) (get-src :right) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 final-bits) (inst lw ntemp3 ntemp3) (inst lw ntemp2 dst) (inst and ntemp1 ntemp3) (inst nor ntemp3 zero-tn ntemp3) (inst and ntemp2 ntemp3) (inst or ntemp1 ntemp2) (inst b done) (inst sw ntemp1 dst))) (defmacro wide-copy-right () '(let ((aligned (gen-label)) (final-bits temp1)) ;; Compute final-bits, the number of bits in the final dst word. (inst addu ntemp3 dst-bit-offset length) (inst and final-bits ntemp3 (fixnumize 31)) ;; Increase src and dst so they point to the end of the buffers instead ;; of the beginning. ;; (inst srl ntemp3 7) (inst sll ntemp3 2) (inst addu dst ntemp3) (inst addu ntemp3 src-bit-offset length) (inst subu ntemp3 final-bits) (inst srl ntemp3 7) (inst sll ntemp3 2) (inst add src ntemp3) ;; Check to see if they are aligned. (inst beq src-bit-offset dst-bit-offset aligned) ;; Calc src-shift (inst subu src-shift dst-bit-offset src-bit-offset) (inst and src-shift (fixnumize 31)) (macrolet ((merge (&rest before-last-inst) `(progn (inst sra ntemp3 src-shift 2) (inst sll ntemp2 ntemp3) (inst subu ntemp3 zero-tn ntemp3) (inst srl ntemp1 ntemp3) ,@before-last-inst (inst or ntemp1 ntemp2))) (get-src (where) (ecase where (:left '(let ((dont-load (gen-label)) (done-load (gen-label))) (inst sltu ntemp1 src-bit-offset dst-bit-offset) (inst bne ntemp1 dont-load) (inst lw ntemp2 src 4) (inst lw ntemp1 src) (merge (inst b done-load)) (emit-label dont-load) (inst sra ntemp3 src-shift 2) (inst sll ntemp1 ntemp2 ntemp3) (emit-label done-load))) (:middle '(progn (inst lw ntemp1 src) (inst lw ntemp2 src 4) (merge) (inst subu src 4))) (:right '(let ((dont-load (gen-label)) (done-load (gen-label))) (inst sltu ntemp1 src-shift final-bits) (inst beq ntemp1 dont-load) (inst lw ntemp1 src) (inst lw ntemp2 src 4) (merge (inst b done-load)) (emit-label dont-load) (inst sra ntemp3 src-shift 2) (inst subu ntemp3 zero-tn ntemp3) (inst srl ntemp1 ntemp3) (emit-label done-load)))))) (wide-copy-right-aux) (inst b done) (inst nop)) (macrolet ((get-src (where) `(progn (inst lw ntemp1 src) ,@(unless (eq where :right) '((inst subu src 4)))))) (emit-label aligned) (wide-copy-right-aux)))) (defmacro wide-copy-right-aux () '(let ((right-aligned (gen-label)) (loop (gen-label)) (check-left (gen-label)) (interior temp2)) (inst beq final-bits right-aligned) (inst nop) (get-src :right) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 final-bits) (inst lw ntemp3 ntemp3) (inst lw ntemp2 dst) (inst and ntemp1 ntemp3) (inst nor ntemp3 ntemp3 zero-tn) (inst and ntemp2 ntemp3) (inst or ntemp2 ntemp1) (inst sw ntemp2 dst) (emit-label right-aligned) (inst subu dst 4) (inst subu src 4) (inst subu ntemp1 length final-bits) (inst srl ntemp1 7) (inst beq ntemp1 check-left) (inst sll interior ntemp1 2) (emit-label loop) (get-src :middle) (inst sw ntemp1 dst) (check-for-interrupts) (inst subu interior 4) (inst bgtz interior loop) (inst subu dst 4) (emit-label check-left) (inst beq dst-bit-offset done) (inst nop) (get-src :left) (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign)) (inst addu ntemp3 dst-bit-offset) (inst lw ntemp3 ntemp3) (inst lw ntemp2 dst) (inst nop) (inst and ntemp2 ntemp3) (inst nor ntemp3 zero-tn ntemp3) (inst and ntemp1 ntemp3) (inst or ntemp1 ntemp2) (inst sw ntemp1 dst))) (defmacro check-for-interrupts () nil) ) ; eval-when (compile eval) ;;;; The actual routines. (define-assembly-routine (copy-to-system-area (:policy :fast-safe) (:translate copy-to-system-area) (:arg-types * tagged-num system-area-pointer tagged-num tagged-num)) ((:arg src-arg descriptor-reg a0-offset) (:arg src-offset any-reg a1-offset) (:arg dst sap-reg nl0-offset) (:arg dst-offset any-reg a2-offset) (:arg length any-reg a3-offset) (:res res descriptor-reg null-offset) (:temp src interior-reg lip-offset) (:temp temp1 descriptor-reg a4-offset) (:temp temp2 descriptor-reg a5-offset) (:temp src-shift descriptor-reg cname-offset) (:temp src-bit-offset descriptor-reg lexenv-offset) (:temp dst-bit-offset descriptor-reg l0-offset) (:temp ntemp1 non-descriptor-reg nl1-offset) (:temp ntemp2 non-descriptor-reg nl2-offset) (:temp ntemp3 non-descriptor-reg nl3-offset) (:temp retaddr non-descriptor-reg nargs-offset)) (progn res) ; don't complain that it's unused. ;; Save the return address. (inst subu retaddr lip-tn code-tn) (inst subu src src-arg vm:other-pointer-type) (inst and ntemp1 dst 3) (inst xor dst ntemp1) (inst sll ntemp1 5) (inst addu dst-offset ntemp1) (do-copy) done ;; Restore the return address. (inst addu lip-tn retaddr code-tn)) (define-assembly-routine (copy-from-system-area (:policy :fast-safe) (:translate copy-from-system-area) (:arg-types system-area-pointer tagged-num * tagged-num tagged-num)) ((:arg src sap-reg nl0-offset) (:arg src-offset any-reg a0-offset) (:arg dst-arg descriptor-reg a1-offset) (:arg dst-offset any-reg a2-offset) (:arg length any-reg a3-offset) (:res res descriptor-reg null-offset) (:temp dst interior-reg lip-offset) (:temp temp1 descriptor-reg a4-offset) (:temp temp2 descriptor-reg a5-offset) (:temp src-shift descriptor-reg cname-offset) (:temp src-bit-offset descriptor-reg lexenv-offset) (:temp dst-bit-offset descriptor-reg l0-offset) (:temp ntemp1 non-descriptor-reg nl1-offset) (:temp ntemp2 non-descriptor-reg nl2-offset) (:temp ntemp3 non-descriptor-reg nl3-offset) (:temp retaddr non-descriptor-reg nargs-offset)) (progn res) ; don't complain that it's unused. ;; Save the return address. (inst sub retaddr lip-tn code-tn) (inst and ntemp1 src 3) (inst xor src ntemp1) (inst sll ntemp1 5) (inst addu src-offset ntemp1) (inst subu dst dst-arg vm:other-pointer-type) (do-copy) done ;; Restore the return address. (inst add lip-tn retaddr code-tn)) (define-assembly-routine (system-area-copy (:policy :fast-safe) (:translate system-area-copy) (:arg-types system-area-pointer tagged-num system-area-pointer tagged-num tagged-num)) ((:arg src sap-reg nl1-offset) (:arg src-offset any-reg a0-offset) (:arg dst sap-reg nl0-offset) (:arg dst-offset any-reg a1-offset) (:arg length any-reg a2-offset) (:res res descriptor-reg null-offset) (:temp temp1 descriptor-reg a4-offset) (:temp temp2 descriptor-reg a5-offset) (:temp src-shift descriptor-reg cname-offset) (:temp src-bit-offset descriptor-reg lexenv-offset) (:temp dst-bit-offset descriptor-reg l0-offset) (:temp ntemp1 non-descriptor-reg nl2-offset) (:temp ntemp2 non-descriptor-reg nl3-offset) (:temp ntemp3 non-descriptor-reg nl4-offset)) (progn res) ; don't complain that it's unused. (inst and ntemp1 src 3) (inst xor src ntemp1) (inst sll ntemp1 5) (inst addu src-offset ntemp1) (inst and ntemp1 dst 3) (inst xor dst ntemp1) (inst sll ntemp1 5) (inst addu dst-offset ntemp1) (do-copy) done) (define-assembly-routine (bit-bash-copy (:policy :fast-safe) (:translate bit-bash-copy) (:arg-types * tagged-num * tagged-num tagged-num)) ((:arg src-arg descriptor-reg a0-offset) (:arg src-offset any-reg a1-offset) (:arg dst-arg descriptor-reg a2-offset) (:arg dst-offset any-reg a3-offset) (:arg length any-reg a4-offset) (:res res descriptor-reg null-offset) (:temp src non-descriptor-reg nl0-offset) (:temp dst non-descriptor-reg nl1-offset) (:temp temp1 descriptor-reg a5-offset) (:temp temp2 descriptor-reg l0-offset) (:temp src-shift descriptor-reg cname-offset) (:temp src-bit-offset descriptor-reg lexenv-offset) (:temp dst-bit-offset descriptor-reg l1-offset) (:temp ntemp1 non-descriptor-reg nl2-offset) (:temp ntemp2 non-descriptor-reg nl3-offset) (:temp ntemp3 non-descriptor-reg nl4-offset)) (progn res) ; don't complain that it's unused. (let ((done (gen-label))) (pseudo-atomic (ntemp1) (inst subu src src-arg vm:other-pointer-type) (inst subu dst dst-arg vm:other-pointer-type) (macrolet ((check-for-interrupts () '(let ((label (gen-label))) (inst and ntemp1 flags-tn (ash 1 interrupted-flag)) (inst beq ntemp1 label) (inst nop) (inst subu src src-arg) (inst subu dst dst-arg) (inst and flags-tn (logxor (ash 1 atomic-flag) #Xffff)) (inst break vm:pending-interrupt-trap) (inst and flags-tn (logxor (ash 1 interrupted-flag) #Xffff)) (inst or flags-tn flags-tn (ash 1 atomic-flag)) (inst addu src src-arg) (inst addu dst dst-arg) (emit-label label)))) (do-copy)) (emit-label done)))) cmucl-21a/src/assembly/mips/support.lisp000066400000000000000000000053201260377556400205440ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; (in-package "MIPS") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (let (#+gengc (ra (make-symbol "RA"))) (values `((inst jal #+gengc ,ra (make-fixup ',name :assembly-routine)) (inst nop)) `(#+gengc (:temporary (:sc descriptor-reg :from (:eval 0) :to (:eval 1) :offset ra-offset) ,ra))))) (:full-call (let ((temp (make-symbol "TEMP")) (nfp-save (make-symbol "NFP-SAVE")) #-gengc (lra (make-symbol "LRA")) #+gengc (ra (make-symbol "RA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn ,nfp-save cur-nfp)) #-gengc (inst compute-lra-from-code ,lra code-tn lra-label ,temp) (note-next-instruction ,vop :call-site) (inst #-gengc j #+gengc jal (make-fixup ',name :assembly-routine)) (inst nop) (emit-return-pc lra-label) (note-this-location ,vop :single-value-return) (without-scheduling () (move csp-tn ocfp-tn) (inst nop)) #-gengc (inst compute-code-from-lra code-tn code-tn lra-label ,temp) #+gengc (inst compute-code-from-ra code-tn ra-tn lra-label ,temp) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) #-gengc (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) #+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 0) :to (:eval 1)) ,ra) #+gengc (:ignore ,ra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save) (:save-p t))))) (:none (values `((inst j (make-fixup ',name :assembly-routine)) (inst nop)) nil)))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst j #-gengc lip-tn #+gengc ra-tn) (inst nop))) (:full-call #-gengc `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg) :offset lra-offset) lip-tn :offset 2)) #+gengc `((inst addu lip-tn ra-tn (* word-bytes 2)) (inst j lip-tn) (inst nop))) (:none))) cmucl-21a/src/assembly/mips/wrlist.lisp000066400000000000000000000233531260377556400203620ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/mips/wrlist.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the assembly routines for write-list support. ;;; (in-package "MIPS") (define-assembly-routine (write-list-record) ((:arg object descriptor-reg a0-offset) (:arg offset non-descriptor-reg nl2-offset) (:arg value descriptor-reg a1-offset) (:temp nl0 non-descriptor-reg nl0-offset) (:temp nl1 non-descriptor-reg nl1-offset) (:temp nl3 non-descriptor-reg nl3-offset) (:temp nl4 non-descriptor-reg nl4-offset) (:temp nl5 non-descriptor-reg nl5-offset) (:temp nargs non-descriptor-reg nargs-offset) (:temp a2 any-reg a2-offset) (:temp a3 any-reg a3-offset) (:temp a4 any-reg a4-offset) (:temp a5 any-reg a5-offset) (:temp cname any-reg cname-offset) (:temp lexenv any-reg lexenv-offset) (:temp l0 any-reg l0-offset) (:temp l1 any-reg l1-offset) (:temp l2 any-reg l2-offset) (:temp l3 any-reg l3-offset) (:temp nfp any-reg nfp-offset) (:temp ocfp any-reg ocfp-offset) (:temp lra any-reg lra-offset)) ;; The write into memory and the write into the write-list have to be atomic. (start-pseudo-atomic) TRY-AGAIN ;; First, make sure there is space available in the write list. (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) (inst nop) (inst bne nl0 nl1 space-available) (inst nop) ;; No space, so we have to call out to gengc_FlushWriteList. ;; We have to save all the descriptor registers on the stack in case ;; we end up collecting garbage while in C. ;; Save all lisp regs on the stack, so the garbage collector can find them. (save-regs-on-stack (object value a2 a3 a4 a5 cname lexenv l0 l1 l2 l3 nfp ocfp code-tn lra null-tn) ;; Convert the return address into an offset. We don't have to save l0 ;; across the call-out because it is one of the saved regs. (inst subu l0 lip-tn code-tn) ;; Decache all the lisp state from the mutator structure. (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) ;; Indicate that we are now in foreign-function-call land. (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) ;; Turn off pseudo-atomic. (end-pseudo-atomic nl0) ;; Move offset to one of the saved registers. (inst move l1 offset) ;; Move the other non-descriptor regs into saved regs. (inst move l2 nl3) (inst move l3 nl4) (inst move nfp nl5) (inst move ocfp nargs) ;; Allocate the stack frame. (inst subu nsp-tn nsp-tn (* 4 word-bytes)) ;; Restore GP (inst li null-tn (make-fixup "_gp" :foreign)) ;; Call-out to gengc_Allocate, setting up the single argument. (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) (inst move nl0 mutator-tn) ;; Deallocate the stack frame. (inst addu nsp-tn nsp-tn (* 4 word-bytes)) ;; Restore offset from the saved reg. (inst move offset l1) ;; Restore the other non-descriptor regs. (inst move nl3 l2) (inst move nl4 l3) (inst move nl5 nfp) (inst move nargs ocfp) ;; Turn pseudo-atomic back on. (start-pseudo-atomic) ;; No longer in foreign-foreign-call land. (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) ;; Cache lisp state from the mutator structure. (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) ;; We can't restore the return address yet, because code hasn't been ;; restored. But if we wait until after code has been restored, ;; then l0 will have been trashed. So we have to move the value ;; out of l0 and into nl0. (inst move nl0 l0) ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) ) ;; Regenerate the return address from the saved offset. (inst addu lip-tn nl0 code-tn) ;; Because we turned off pseudo-atomic, we might have taken an interrupt, ;; so we can't be sure the write-list will be empty. (inst b try-again) (inst nop) SPACE-AVAILABLE (inst addu nl1 object offset) (inst sw nl1 nl0) (inst sw value nl1) (inst addu nl0 4) (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) (end-pseudo-atomic nl0)) (define-assembly-routine (set-fdefn-function) ((:arg fdefn descriptor-reg a0-offset) (:arg function descriptor-reg a1-offset) (:temp nl0 non-descriptor-reg nl0-offset) (:temp nl1 non-descriptor-reg nl1-offset) (:temp nl2 non-descriptor-reg nl2-offset) (:temp nl3 non-descriptor-reg nl3-offset) (:temp nl4 non-descriptor-reg nl4-offset) (:temp nl5 non-descriptor-reg nl5-offset) (:temp nargs non-descriptor-reg nargs-offset) (:temp a2 any-reg a2-offset) (:temp a3 any-reg a3-offset) (:temp a4 any-reg a4-offset) (:temp a5 any-reg a5-offset) (:temp cname any-reg cname-offset) (:temp lexenv any-reg lexenv-offset) (:temp l0 any-reg l0-offset) (:temp l1 any-reg l1-offset) (:temp l2 any-reg l2-offset) (:temp l3 any-reg l3-offset) (:temp nfp any-reg nfp-offset) (:temp ocfp any-reg ocfp-offset) (:temp lra any-reg lra-offset)) ;; The write into memory and the write into the write-list have to be atomic. (start-pseudo-atomic) ;; First, check to see if we don't need to make a write-list entry because ;; the fdefn object is ephemeral. (inst srl nl0 fdefn 30) (inst bne nl0 zero-tn just-do-write) (inst nop) TRY-AGAIN ;; Now make sure there is space available in the write list. (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes)) (inst nop) (inst bne nl0 nl1 space-available) (inst nop) ;; No space, so we have to call out to gengc_FlushWriteList. ;; We have to save all the descriptor registers on the stack in case ;; we end up collecting garbage while in C. ;; Save all lisp regs on the stack, so the garbage collector can find them. (save-regs-on-stack (fdefn function a2 a3 a4 a5 cname lexenv l0 l1 l2 l3 nfp ocfp code-tn lra null-tn) ;; Convert the return address into an offset. We don't have to save l0 ;; across the call-out because it is one of the saved regs. (inst subu l0 lip-tn code-tn) ;; Decache all the lisp state from the mutator structure. (storew csp-tn mutator-tn mutator-control-stack-pointer-slot) (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot) ;; Indicate that we are now in foreign-function-call land. (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot) ;; Turn off pseudo-atomic. (end-pseudo-atomic nl0) ;; Move the non-descriptor regs into saved regs. (inst move l1 nl2) (inst move l2 nl3) (inst move l3 nl4) (inst move nfp nl5) (inst move ocfp nargs) ;; Allocate the stack frame. (inst subu nsp-tn nsp-tn (* 4 word-bytes)) ;; Restore GP (inst li null-tn (make-fixup "_gp" :foreign)) ;; Call-out to gengc_Allocate, setting up the single argument. (inst jal (make-fixup "gengc_FlushWriteList" :foreign)) (inst move nl0 mutator-tn) ;; Deallocate the stack frame. (inst addu nsp-tn nsp-tn (* 4 word-bytes)) ;; Restore the non-descriptor regs. (inst move nl2 l1) (inst move nl3 l2) (inst move nl4 l3) (inst move nl5 nfp) (inst move nargs ocfp) ;; Turn pseudo-atomic back on. (start-pseudo-atomic) ;; No longer in foreign-foreign-call land. (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot) ;; Cache lisp state from the mutator structure. (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot) (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot) ;; We can't restore the return address yet, because code hasn't been ;; restored. But if we wait until after code has been restored, ;; then l0 will have been trashed. So we have to move the value ;; out of l0 and into nl0. (inst move nl0 l0) ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack) ) ;; Regenerate the return address from the saved offset. (inst addu lip-tn nl0 code-tn) ;; Because we turned off pseudo-atomic, we might have taken an interrupt, ;; so we can't be sure the write-list will be empty. (inst b try-again) (inst nop) SPACE-AVAILABLE (inst subu nl1 fdefn other-pointer-type) (inst sw nl1 nl0) (inst addu nl0 4) (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes)) JUST-DO-WRITE (load-type nl0 function (- vm:function-pointer-type)) (inst nop) (inst xor nl0 vm:closure-header-type) (inst beq nl0 zero-tn closure) (inst xor nl0 (logxor closure-header-type funcallable-instance-header-type)) (inst beq nl0 zero-tn closure) (inst xor nl0 (logxor funcallable-instance-header-type function-header-type)) (inst beq nl0 zero-tn normal-fn) (inst addu nl1 function (- (ash vm:function-header-code-offset vm:word-shift) vm:function-pointer-type)) (end-pseudo-atomic nl0) (error-call nil kernel:object-not-function-error function) CLOSURE (inst li nl1 (make-fixup "closure_tramp" :foreign)) NORMAL-FN (storew function fdefn fdefn-function-slot other-pointer-type) (storew nl1 fdefn fdefn-raw-addr-slot other-pointer-type) (end-pseudo-atomic nl0)) cmucl-21a/src/assembly/ppc/000077500000000000000000000000001260377556400157515ustar00rootroot00000000000000cmucl-21a/src/assembly/ppc/alloc.lisp000066400000000000000000000012721260377556400177360ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/ppc/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocating simple objects. ;;; ;;; Written by William Lott. ;;; (in-package "PPC") ;;; But we do everything inline now that we have a better pseudo-atomic. cmucl-21a/src/assembly/ppc/arith.lisp000066400000000000000000000303351260377556400177550ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/ppc/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; (in-package "PPC") ;;;; Addition and subtraction. (define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp flag non-descriptor-reg nl3-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp lip interior-reg lip-offset) (:temp ocfp any-reg ocfp-offset)) ; Clear the damned "sticky overflow" bit in :cr0 and :xer (inst mtxer zero-tn) (inst or temp x y) (inst andi. temp temp 3) (inst bne DO-STATIC-FUN) (inst addo. temp x y) (inst bns done) (inst srawi temp x 2) (inst srawi temp2 y 2) (inst add temp2 temp2 temp) (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lwz code-tn null-tn (static-function-offset 'two-arg-+)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) DONE (move res temp)) (define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp flag non-descriptor-reg nl3-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp lip interior-reg lip-offset) (:temp ocfp any-reg ocfp-offset)) ; Clear the damned "sticky overflow" bit in :cr0 (inst mtxer zero-tn) (inst or temp x y) (inst andi. temp temp 3) (inst bne DO-STATIC-FUN) (inst subo. temp x y) (inst bns done) (inst srawi temp x 2) (inst srawi temp2 y 2) (inst sub temp2 temp temp2) (with-fixed-allocation (res flag temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lwz code-tn null-tn (static-function-offset 'two-arg--)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) DONE (move res temp)) ;;;; Multiplication (define-assembly-routine (generic-* (:cost 50) (:return-style :full-call) (:translate *) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) (:temp pa-flag non-descriptor-reg nl3-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. But first ... (inst mtxer zero-tn) (inst or temp x y) (inst andi. temp temp 3) ;; Remove the tag from both args, so I don't get so confused. (inst srawi temp x 2) (inst srawi nargs y 2) (inst bne DO-STATIC-FUN) (inst mullwo. lo nargs temp) (inst srawi hi lo 31) ; hi = 32 copies of lo's sign bit (inst bns ONE-WORD-ANSWER) (inst mulhw hi nargs temp) (inst b CONS-BIGNUM) ONE-WORD-ANSWER ; We know that all of the overflow bits are clear. (inst addo temp lo lo) (inst addo. res temp temp) (inst bns GO-HOME) CONS-BIGNUM ;; Allocate a BIGNUM for the result. (with-fixed-allocation (res pa-flag temp bignum-type (+ 2 bignum-digits-offset)) (let ((one-word (gen-label))) ;; We start out assuming that we need one word. Is that correct? (inst srawi temp lo 31) (inst xor. temp temp hi) (inst li temp (logior (ash 1 type-bits) bignum-type)) (inst beq one-word) ;; Nope, we need two, so allocate the additional space. (inst li temp (logior (ash 2 type-bits) bignum-type)) (storew hi res (1+ bignum-digits-offset) other-pointer-type) (emit-label one-word) (storew temp res 0 other-pointer-type) (storew lo res bignum-digits-offset other-pointer-type))) ;; Out of here GO-HOME (lisp-return lra lip :offset 2) DO-STATIC-FUN (inst lwz code-tn null-tn (static-function-offset 'two-arg-*)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) LOW-FITS-IN-FIXNUM (move res lo)) (macrolet ((frob (name note cost type sc) `(define-assembly-routine (,name (:note ,note) (:cost ,cost) (:translate *) (:policy :fast-safe) (:arg-types ,type ,type) (:result-types ,type)) ((:arg x ,sc nl0-offset) (:arg y ,sc nl1-offset) (:res res ,sc nl0-offset)) ,@(when (eq type 'tagged-num) `((inst srawi x x 2))) (inst mullw res x y)))) (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) (frob signed-* "unsigned *" 41 signed-num signed-reg) (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) ;;;; Division. (define-assembly-routine (positive-fixnum-truncate (:note "unsigned fixnum truncate") (:cost 45) (:translate truncate) (:policy :fast-safe) (:arg-types positive-fixnum positive-fixnum) (:result-types positive-fixnum positive-fixnum)) ((:arg dividend any-reg nl0-offset) (:arg divisor any-reg nl1-offset) (:res quo any-reg nl2-offset) (:res rem any-reg nl0-offset)) (assert (location= rem dividend)) (let ((error (generate-error-code nil division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) (inst divwu quo dividend divisor) (inst mullw divisor quo divisor) (inst sub rem dividend divisor) (inst slwi quo quo 2)) (define-assembly-routine (fixnum-truncate (:note "fixnum truncate") (:cost 50) (:policy :fast-safe) (:translate truncate) (:arg-types tagged-num tagged-num) (:result-types tagged-num tagged-num)) ((:arg dividend any-reg nl0-offset) (:arg divisor any-reg nl1-offset) (:res quo any-reg nl2-offset) (:res rem any-reg nl0-offset)) (assert (location= rem dividend)) (let ((error (generate-error-code nil division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) (inst divw quo dividend divisor) (inst mullw divisor quo divisor) (inst subf rem divisor dividend) (inst slwi quo quo 2)) (define-assembly-routine (signed-truncate (:note "(signed-byte 32) truncate") (:cost 60) (:policy :fast-safe) (:translate truncate) (:arg-types signed-num signed-num) (:result-types signed-num signed-num)) ((:arg dividend signed-reg nl0-offset) (:arg divisor signed-reg nl1-offset) (:res quo signed-reg nl2-offset) (:res rem signed-reg nl0-offset)) (let ((error (generate-error-code nil division-by-zero-error dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) (inst divw quo dividend divisor) (inst mullw divisor quo divisor) (inst subf rem divisor dividend)) ;;;; Comparison (macrolet ((define-cond-assem-rtn (name translate static-fn cmp) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst or nargs x y) (inst andi. nargs nargs 3) (inst cmpw :cr1 x y) (inst beq DO-COMPARE) DO-STATIC-FN (inst lwz code-tn null-tn (static-function-offset ',static-fn)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) DO-COMPARE (load-symbol res t) (inst b? :cr1 ,cmp done) (inst mr res null-tn) DONE))) (define-cond-assem-rtn generic-< < two-arg-< :lt) (define-cond-assem-rtn generic-<= <= two-arg-<= :le) (define-cond-assem-rtn generic-> > two-arg-> :gt) (define-cond-assem-rtn generic->= >= two-arg->= :ge)) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst cmpw :cr1 x y) (inst andi. nargs x 3) (inst beq :cr1 RETURN-T) (inst beq RETURN-NIL) ; x was fixnum, not eq y (inst andi. nargs y 3) (inst bne DO-STATIC-FN) RETURN-NIL (inst mr res null-tn) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lwz code-tn null-tn (static-function-offset 'eql)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst or nargs x y) (inst andi. nargs nargs 3) (inst cmpw :cr1 x y) (inst bne DO-STATIC-FN) (inst beq :cr1 RETURN-T) (inst mr res null-tn) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lwz code-tn null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-/= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate /=) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst or nargs x y) (inst andi. nargs nargs 3) (inst cmpw :cr1 x y) (inst bne DO-STATIC-FN) (inst beq :cr1 RETURN-NIL) (load-symbol res t) (lisp-return lra lip :offset 2) DO-STATIC-FN (inst lwz code-tn null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) RETURN-NIL (inst mr res null-tn)) cmucl-21a/src/assembly/ppc/array.lisp000066400000000000000000000124501260377556400177620ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at ;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of Spice Lisp, please contact ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/ppc/array.lisp $ ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; (in-package "PPC") (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp pa-flag non-descriptor-reg nl3-offset) (:temp vector descriptor-reg a3-offset) #+gencgc (:temp temp non-descriptor-reg nl2-offset)) (pseudo-atomic (pa-flag) (inst addi ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) (inst clrrwi ndescr ndescr lowtag-bits) (allocation vector ndescr other-pointer-type #+gencgc :temp-tn #+gencgc temp #+gencgc :flag-tn #+gencgc pa-flag) (inst srwi ndescr type vm:word-shift) (storew ndescr vector 0 vm:other-pointer-type) (storew length vector vm:vector-length-slot vm:other-pointer-type)) ;; Like the sparc port, we need to touch the last word to make sure ;; this page is paged in. Do we need to touch all pages? ;; ;; FIXME: This seems to cause some problems. Turn it off for now. ;; (storew zero-tn alloc-tn -1) (move result vector)) ;;;; Hash primitives #+assembler (defparameter sxhash-simple-substring-entry (gen-label)) (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp temp non-descriptor-reg nl2-offset) (:temp offset non-descriptor-reg nl3-offset)) (declare (ignore result accum data temp offset)) (loadw length string vm:vector-length-slot vm:other-pointer-type) (inst b sxhash-simple-substring-entry)) #+nil (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp temp non-descriptor-reg nl2-offset) (:temp offset non-descriptor-reg nl3-offset)) (emit-label sxhash-simple-substring-entry) (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type)) (move accum zero-tn) (inst b test) LOOP (inst xor accum accum data) (inst slwi temp accum 27) (inst srwi accum accum 5) (inst or accum accum temp) (inst addi offset offset 4) TEST (inst subic. length length (fixnumize 4)) (inst lwzx data string offset) (inst bge loop) (inst addic. length length (fixnumize 4)) (inst neg length length) (inst beq done) (inst slwi length length 1) (inst srw data data length) (inst xor accum accum data) DONE (inst slwi result accum 5) (inst srwi result result 3)) ;; One-at-a-time hash algorithm. See assembly/sparc/array.lisp for a ;; description. (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp temp non-descriptor-reg nl2-offset) (:temp offset non-descriptor-reg nl3-offset)) (emit-label sxhash-simple-substring-entry) #+unicode (inst slwi length length 1) ; Number of bytes = twice the length (inst li offset (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)) (move accum zero-tn) (inst b test) LOOP ;; hash += key[i] (inst add accum accum data) ;; hash += (hash << 10) (inst slwi temp accum 10) (inst add accum accum temp) ;; hash ^= (hash >> 6) (inst srwi temp accum 6) (inst xor accum accum temp) (inst addi offset offset 1) TEST (inst subic. length length (fixnumize 1)) (inst lbzx data string offset) (inst bge loop) ;; hash += (hash << 3) (inst slwi temp accum 3) (inst add accum accum temp) ;; hash ^= (hash >> 11) (inst srwi temp accum 11) (inst xor accum accum temp) ;; hash += (hash << 15); (inst slwi temp accum 15) (inst add accum accum temp) ;; Make the result a positive fixnum. Shifting it left, then right ;; does what we want, and extracts the bits we need. (inst slwi accum accum 3) (inst srwi result accum 1)) cmucl-21a/src/assembly/ppc/assem-rtns.lisp000066400000000000000000000144001260377556400207350ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at ;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of Spice Lisp, please contact ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/ppc/assem-rtns.lisp $ ;;; ;;; (in-package "PPC") ;;;; Return-multiple with other than one value #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) (:temp ocfp any-reg nl1-offset) (:temp lra descriptor-reg lra-offset) ;; These are just needed to facilitate the transfer (:temp lip interior-reg lip-offset) (:temp count any-reg nl2-offset) (:temp src any-reg nl3-offset) (:temp dst any-reg cfunc-offset) (:temp temp descriptor-reg l0-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset)) ;; Note, because of the way the return-multiple vop is written, we can ;; assume that we are never called with nvals == 1 and that a0 has already ;; been loaded. (inst cmpwi nvals 0) (inst ble default-a0-and-on) (inst cmpwi nvals (fixnumize 2)) (inst lwz a1 vals (* 1 vm:word-bytes)) (inst ble default-a2-and-on) (inst cmpwi nvals (fixnumize 3)) (inst lwz a2 vals (* 2 vm:word-bytes)) (inst ble default-a3-and-on) (inst cmpwi nvals (fixnumize 4)) (inst lwz a3 vals (* 3 vm:word-bytes)) (inst ble done) ;; Copy the remaining args to the top of the stack. (inst addi src vals (* 4 vm:word-bytes)) (inst addi dst cfp-tn (* 4 vm:word-bytes)) (inst addic. count nvals (- (fixnumize 4))) LOOP (inst subic. count count (fixnumize 1)) (inst lwz temp src 0) (inst addi src src vm:word-bytes) (inst stw temp dst 0) (inst addi dst dst vm:word-bytes) (inst bge loop) (inst b done) DEFAULT-A0-AND-ON (inst mr a0 null-tn) (inst mr a1 null-tn) DEFAULT-A2-AND-ON (inst mr a2 null-tn) DEFAULT-A3-AND-ON (inst mr a3 null-tn) DONE ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst add csp-tn ocfp-tn nvals) ;; Return. (lisp-return lra lip)) ;;;; tail-call-variable. #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) (:temp lexenv descriptor-reg lexenv-offset) ;; We need to compute this (:temp nargs any-reg nargs-offset) ;; These are needed by the blitting code. (:temp src any-reg nl1-offset) (:temp dst any-reg nl2-offset) (:temp count any-reg nl3-offset) (:temp temp descriptor-reg l0-offset) (:temp lip interior-reg lip-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset)) ;; Calculate NARGS (as a fixnum) (inst sub nargs csp-tn args) ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst lwz a0 args (* 0 vm:word-bytes)) (inst lwz a1 args (* 1 vm:word-bytes)) (inst lwz a2 args (* 2 vm:word-bytes)) (inst lwz a3 args (* 3 vm:word-bytes)) ;; Calc SRC, DST, and COUNT (inst addic. count nargs (fixnumize (- register-arg-count))) (inst addi src args (* vm:word-bytes register-arg-count)) (inst ble done) (inst addi dst cfp-tn (* vm:word-bytes register-arg-count)) LOOP ;; Copy one arg. (inst lwz temp src 0) (inst addi src src vm:word-bytes) (inst stw temp dst 0) (inst addic. count count (fixnumize -1)) (inst addi dst dst vm:word-bytes) (inst bgt loop) DONE ;; We are done. Do the jump. (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) (lisp-jump temp lip)) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:return-style :none) (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) a0-offset) (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lra descriptor-reg lra-offset) (:temp lip interior-reg lip-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst cmpwi block 0) (inst beq error)) (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) (loadw target-uwp block vm:unwind-block-current-uwp-slot) (inst cmpw cur-uwp target-uwp) (inst bne do-uwp) (move cur-uwp block) DO-EXIT (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) (lisp-return lra lip :frob-code nil) DO-UWP (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) (store-symbol-value next-uwp lisp::*current-unwind-protect-block*) (inst b do-exit)) (define-assembly-routine (throw (:return-style :none)) ((:arg target descriptor-reg a0-offset) (:arg start any-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset)) (declare (ignore start count)) (load-symbol-value catch lisp::*current-catch-block*) loop (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst cmpwi catch 0) (inst beq error)) (loadw tag catch vm:catch-block-tag-slot) (inst cmpw tag target) (inst beq exit) (loadw catch catch vm:catch-block-previous-catch-slot) (inst b loop) exit (move target catch) ;; Recycle catch as a temp (inst lr catch (make-fixup 'unwind :assembly-routine)) (inst mtctr catch) (inst bctr)) cmucl-21a/src/assembly/ppc/support.lisp000066400000000000000000000050571260377556400203650ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/ppc/support.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "PPC") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (let ((temp (make-symbol "TEMP"))) (values `((inst lr ,temp (make-fixup ',name :assembly-routine)) (inst mtctr ,temp) (inst bctrl)) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp))))) (:full-call (let ((temp (make-symbol "TEMP")) (nfp-save (make-symbol "NFP-SAVE")) (lra (make-symbol "LRA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn ,nfp-save cur-nfp)) (inst compute-lra-from-code ,lra code-tn lra-label ,temp) (note-next-instruction ,vop :call-site) (inst lr ,temp (make-fixup ',name :assembly-routine)) (inst mtctr ,temp) (inst bctr) (emit-return-pc lra-label) (note-this-location ,vop :single-value-return) (without-scheduling () (move csp-tn ocfp-tn) (inst nop)) (inst compute-code-from-lra code-tn code-tn lra-label ,temp) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save) (:save-p :compute-only))))) (:none (let ((temp (make-symbol "TEMP"))) (values `((inst lr ,temp (make-fixup ',name :assembly-routine)) (inst mtctr ,temp) (inst bctr)) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp))))))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst blr))) (:full-call `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg *backend*) :offset lra-offset) (make-random-tn :kind :normal :sc (sc-or-lose 'interior-reg *backend*) :offset lip-offset) :offset 2))) (:none))) cmucl-21a/src/assembly/rt/000077500000000000000000000000001260377556400156145ustar00rootroot00000000000000cmucl-21a/src/assembly/rt/alloc.lisp000066400000000000000000000064441260377556400176070ustar00rootroot00000000000000;;; -*- Package: RT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/rt/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/rt/alloc.lisp $ ;;; ;;; Stuff to handle allocating simple objects. ;;; ;;; Written by William Lott. ;;; Converted to the IBM RT by Bill Chiles. ;;; (in-package "RT") (define-for-each-primitive-object (obj) (let* ((options (primitive-object-options obj)) (alloc-trans (getf options :alloc-trans)) (alloc-vop (getf options :alloc-vop alloc-trans)) (header (primitive-object-header obj)) (lowtag (primitive-object-lowtag obj)) (size (primitive-object-size obj)) (variable-length (primitive-object-variable-length obj)) (need-unbound-marker nil)) (collect ((args) (init-forms)) (when (and alloc-vop variable-length) (args 'extra-words)) (dolist (slot (primitive-object-slots obj)) (let* ((name (slot-name slot)) (offset (slot-offset slot))) (ecase (getf (slot-options slot) :init :zero) (:zero) (:null (init-forms `(storew null-tn result ,offset ,lowtag))) (:unbound (setf need-unbound-marker t) (init-forms `(storew temp result ,offset ,lowtag))) (:arg (args name) (init-forms `(storew ,name result ,offset ,lowtag)))))) (when (and (null alloc-vop) (args)) (error "Slots ~S want to be initialized, but there is no alloc vop ~ defined for ~S." (args) (primitive-object-name obj))) (when alloc-vop `(define-assembly-routine (,alloc-vop (:cost 35) ,@(when alloc-trans `((:translate ,alloc-trans))) (:policy :fast-safe)) (,@(let ((arg-offsets (cdr register-arg-offsets))) (mapcar #'(lambda (name) (unless arg-offsets (error "Too many args in ~S" alloc-vop)) `(:arg ,name (descriptor-reg any-reg) ,(pop arg-offsets))) (args))) (:temp alloc non-descriptor-reg nl0-offset) (:temp temp non-descriptor-reg ocfp-offset) (:res result descriptor-reg a0-offset)) (pseudo-atomic (temp) (load-symbol-value alloc *allocation-pointer*) (inst cal result alloc ,lowtag) ,@(cond ((and header variable-length) `((inst cal temp extra-words (fixnumize (1- ,size))) (inst cas alloc temp alloc) (inst sl temp (- type-bits word-shift)) (inst oil temp ,header) (storew temp result 0 ,lowtag) (inst cal alloc alloc (+ (fixnumize 1) lowtag-mask)) (inst li temp (lognot lowtag-mask)) (inst n alloc temp))) (variable-length (error ":REST-P T with no header in ~S?" (primitive-object-name obj))) (header `((inst cal alloc alloc (pad-data-block ,size)) (inst li temp ,(logior (ash (1- size) type-bits) (symbol-value header))) (storew temp result 0 ,lowtag))) (t `((inst cal alloc alloc (pad-data-block ,size))))) ,@(when need-unbound-marker `((inst li temp unbound-marker-type))) ,@(init-forms) (store-symbol-value alloc *allocation-pointer*)) (load-symbol-value temp *internal-gc-trigger*) (inst tlt temp alloc)))))) cmucl-21a/src/assembly/rt/arith.lisp000066400000000000000000000335221260377556400176210ustar00rootroot00000000000000;;; -*- Package: RT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/rt/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/rt/arith.lisp $ ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; Converted to IBM RT by Bill Chiles. (in-package "RT") (define-assembly-routine (generic-+ (:cost 25) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) ;; Use ocfp as a temporary result. (move ocfp x) (inst a ocfp y) (inst bnc :ov fixnum-result) ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits ;; and do the add again. (move ocfp x) (inst sar ocfp 2) (move temp y) (inst sar temp 2) (inst a ocfp temp) ;; Allocate a bignum for sum. (with-fixed-allocation (res temp cname bignum-type (1+ bignum-digits-offset)) (storew ocfp res bignum-digits-offset other-pointer-type)) ;; Now get out of here. (lisp-return lra lip :offset 1) DO-STATIC-FUN (load-symbol cname 'two-arg-+) (inst li nargs (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp cfp-tn) ;; Tail call TWO-ARG-+. (inst bx lip) (move cfp-tn csp-tn) FIXNUM-RESULT ;; Ocfp was used for the temporary result. (move res ocfp)) (define-assembly-routine (generic-- (:cost 25) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) ;; Use ocfp as a temporary result. (move ocfp x) (inst s ocfp y) (inst bnc :ov fixnum-result) ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits ;; and do the subtract again. (move ocfp x) (inst sar ocfp 2) (move temp y) (inst sar temp 2) (inst s ocfp temp) ;; Allocate a bignum for sum. (with-fixed-allocation (res temp cname bignum-type (1+ bignum-digits-offset)) (storew ocfp res bignum-digits-offset other-pointer-type)) ;; Now get out of here. (lisp-return lra lip :offset 1) DO-STATIC-FUN (load-symbol cname 'two-arg--) (inst li nargs (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp cfp-tn) ;; Tail call TWO-ARG-+. (inst bx lip) (move cfp-tn csp-tn) FIXNUM-RESULT ;; Ocfp was used for the temporary result. (move res ocfp)) (define-assembly-routine (generic-* (:cost 70) (:return-style :full-call) (:translate *) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp alloc word-pointer-reg a2-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs/high non-descriptor-reg nargs-offset) (:temp ocfp/low non-descriptor-reg ocfp-offset) (:temp cname descriptor-reg cname-offset)) ;; If either arg is not a fixnum, call the static function. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) ;; Remove the tag from one arg so that the result will have the correct ;; fixnum lowtag. Without this, the result if off by a factor of 16, but we ;; want it off by a factor of 4 (the fixnum lowtag). (move temp x) (inst sar temp 2) ;; Setup system register for multiply. (inst mtmqscr temp) ;; Do the multiply. ;; Subtract high from high to set it to zero and to set the C0 condition ;; bit appropriately for the m instruction. (inst s nargs/high nargs/high) (dotimes (i 16) (inst m nargs/high y)) (inst mfmqscr res) ;; Check to see if the result will fit in a fixnum. (I.e. the high word is ;; just 32 copies of the sign bit of the low word). (move temp res) (inst sar temp 31) (inst c temp nargs/high) (inst bc :eq DONE) ;; Build two bignum-digits by shifting the double word high:res down two bits ;; into high:low to get rid of the fixnum lowtag. (move ocfp/low res) (inst sr ocfp/low 2) (move temp nargs/high) (inst sl temp 30) (inst o ocfp/low temp) (inst sar nargs/high 2) ;; Allocate a bignum for the result. (pseudo-atomic (temp) (let ((one-word (gen-label))) (load-symbol-value alloc *allocation-pointer*) (inst cal res alloc other-pointer-type) ;; Assume we need one word. (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset))) ;; Is that correct? (move temp ocfp/low) (inst sar temp 31) (inst c temp nargs/high) (inst bcx :eq one-word) (inst li temp (logior (ash 1 type-bits) bignum-type)) ;; Nope, we need two, so allocate the addition space. (inst cal alloc alloc (- (pad-data-block (+ 2 bignum-digits-offset)) (pad-data-block (1+ bignum-digits-offset)))) (inst li temp (logior (ash 2 type-bits) bignum-type)) (storew nargs/high res (1+ bignum-digits-offset) other-pointer-type) (emit-label one-word) (store-symbol-value alloc *allocation-pointer*) (storew temp res 0 other-pointer-type) (storew ocfp/low res bignum-digits-offset other-pointer-type))) (load-symbol-value temp *internal-gc-trigger*) (inst tlt temp alloc) ;; Out of here (lisp-return lra lip :offset 1) DO-STATIC-FUN (load-symbol cname 'two-arg-*) (inst li nargs/high (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp/low cfp-tn) (inst bx lip) (move cfp-tn csp-tn) DONE) (define-assembly-routine (generic-truncate (:cost 95) (:return-style :full-call) (:translate truncate) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res quo (descriptor-reg any-reg) a0-offset) (:res rem (descriptor-reg any-reg) a1-offset) (:temp temp1 non-descriptor-reg nl0-offset) (:temp alloc word-pointer-reg a2-offset) (:temp lip interior-reg lip-offset) ;; High holds the sign of x and becomes the remainder. (:temp nargs/high non-descriptor-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp/temp2 non-descriptor-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (move temp1 x) (inst nilz temp1 3) (inst bnc :eq DO-STATIC-FUN) (move temp1 y) (inst nilz temp1 3) (inst bnc :eq DO-STATIC-FUN) ;; Make sure y is not 0, 1, or -1. (inst c y 0) (inst bcx :eq zero-divisor) (inst c y (fixnumize 1)) (inst bcx :eq one-divisor) (inst c y (fixnumize -1)) (inst bc :eq neg-one-divisor) ;; Do the division. (move nargs/high x) (inst sar nargs/high 31) (inst mtmqscr x) (dotimes (i 32) (inst d nargs/high y)) ;; Check preliminary remainder by considering signs of high and y. ;; This is an extra step to account for the non-restoring divide-step instr. ;; We don't actually have to check this since the d instruction set :c0 ;; when the signs of high and y are the same. (inst bc :c0 rem-okay) (inst a nargs/high y) REM-OKAY ;; The RT gives us some random division concept, but we're writing TRUNCATE. ;; The fixup involves adding one to the quotient and subtracting the divisor ;; from the remainder under certain circumstances: ;; IF the remainder is zero, we're done. (inst c nargs/high 0) (inst bc :eq move-results) ;; ELSE-IF the remainder is equal to the divisor, we can obviously take ;; one more divisor out of the dividend, so do it. (inst c nargs/high y) (inst bc :eq do-it) ;; ELSE-IF the divisor and dividend had different signs, adjust the results. (move temp1 x) (inst x temp1 y) (inst bnc :lt move-results) DO-IT ;; Add 1 to quotient and subtract divisor from remainder. (inst mfmqscr temp1) (inst sl temp1 2) (inst a quo temp1 (fixnumize 1)) ;; Since rem and y are the same register, this subtracts the divisor from ;; the remainder, putting the result in our rem result register. (inst sf y nargs/high) (inst b done) MOVE-RESULTS (inst mfmqscr temp1) (inst sl temp1 2) (move quo temp1) ;; The remainder is always on the same order of magnitude as the dividend, ;; so it already has fixnum lowtag bits. (move rem nargs/high) (inst b done) DO-STATIC-FUN (load-symbol cname 'truncate) (inst li nargs/high (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp/temp2 cfp-tn) ;; Get out of here, doing a tail call. (inst bx lip) (move cfp-tn csp-tn) ZERO-DIVISOR ;; signal an error somehow. NEG-ONE-DIVISOR (inst li rem 0) (inst neg quo x) ;; If quo still fits in a fixnum, go to done. (inst bnc :ov done) ;; Allocate a bignum for quo. (with-fixed-allocation (temp1 ocfp/temp2 alloc bignum-type (+ 2 bignum-digits-offset)) ;; If we overflowed quo, then we must have made a positive value from a ;; negative one. The overflow would be one bit and some zero's for sign. (inst li ocfp/temp2 0) (storew quo temp1 bignum-digits-offset other-pointer-type) (storew ocfp/temp2 temp1 (1+ bignum-digits-offset) other-pointer-type)) (move quo temp1) (inst b done) ONE-DIVISOR (inst li rem 0) (move quo x) DONE) ;;;; Conditionals (define-assembly-routine (generic-< (:cost 25) (:return-style :full-call) (:translate <) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) ;; They are both fixnums, we can compare them. (inst c x y) (inst bcx :lt DONE) (load-symbol res t) (inst bx DONE) (move res null-tn) DO-STATIC-FUN (load-symbol cname 'two-arg-<) (inst li nargs (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp cfp-tn) ;; Tail call TWO-ARG->. (inst bx lip) (move cfp-tn csp-tn) DONE) (define-assembly-routine (generic-> (:cost 25) (:return-style :full-call) (:translate >) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) ;; They are both fixnums, we can compare them. (inst c x y) (inst bcx :gt DONE) (load-symbol res t) (inst bx DONE) (move res null-tn) DO-STATIC-FUN (load-symbol cname 'two-arg->) (inst li nargs (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp cfp-tn) ;; Tail call TWO-ARG->. (inst bx lip) (move cfp-tn csp-tn) DONE) (define-assembly-routine (generic-= (:cost 25) (:return-style :full-call) (:translate =) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp cname descriptor-reg cname-offset) (:temp ocfp any-reg ocfp-offset)) ;; If they are eq, they must be = (inst c x y) (inst bc :eq TRUE) ;; If both args are fixnums, we know the result is NIL. Otherwise, we ;; have to hit the static fun. (move temp x) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (move temp y) (inst nilz temp 3) (inst bnc :eq DO-STATIC-FUN) (inst bx DONE) (move res null-tn) DO-STATIC-FUN (load-symbol cname 'two-arg-=) (inst li nargs (fixnumize 2)) (loadw lip cname symbol-raw-function-addr-slot other-pointer-type) (move ocfp cfp-tn) ;; Tail call TWO-ARG-=. (inst bx lip) (move cfp-tn csp-tn) TRUE (load-symbol res t) DONE) cmucl-21a/src/assembly/rt/array.lisp000066400000000000000000000076221260377556400176320ustar00rootroot00000000000000;;; -*- Package: RT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/rt/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/rt/array.lisp $ ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; (in-package "RT") (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp alloc word-pointer-reg ocfp-offset) (:temp vector descriptor-reg cname-offset)) (pseudo-atomic (ndescr) (load-symbol-value alloc *allocation-pointer*) (inst cal vector alloc vm:other-pointer-type) (inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits)) (* vm:vector-data-offset vm:word-bytes))) (inst cas alloc alloc words) (inst li ndescr (lognot vm:lowtag-mask)) (inst n alloc ndescr) (move ndescr type) (inst sr ndescr vm:word-shift) (storew ndescr vector 0 vm:other-pointer-type) (storew length vector vm:vector-length-slot vm:other-pointer-type) (store-symbol-value alloc *allocation-pointer*)) (load-symbol-value ndescr *internal-gc-trigger*) (inst tlt ndescr alloc) (move result vector)) ;;;; Hash primitives (defparameter sxhash-simple-substring-entry (gen-label)) (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nargs-offset) (:temp temp non-descriptor-reg ocfp-offset)) (declare (ignore result accum data temp)) (inst bx sxhash-simple-substring-entry) (loadw length string vm:vector-length-slot vm:other-pointer-type)) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nargs-offset) (:temp temp non-descriptor-reg ocfp-offset) (:temp lip interior-reg lip-offset)) (emit-label sxhash-simple-substring-entry) ;; Get a stack slot to save the return-pc. (inst inc csp-tn word-bytes) ;; Save the return-pc as a byte offset from the component start, shifted ;; left to look like a fixnum. (inst s lip code-tn) (inst sl lip 2) (storew lip csp-tn (* -1 word-bytes)) ;; Compute start of string as interior pointer. (inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type)) (inst bx test) (inst li accum 0) LOOP (inst x accum data) (move temp accum) (inst sl temp 27) (inst sr accum 5) (inst o accum temp) (inst inc lip 4) TEST (inst s length (fixnumize 4)) (inst bncx :lt loop) (loadw data lip) (inst a length (fixnumize 4)) (inst bc :eq done) (inst neg length) (inst sl length 1) (inst nilz length #x1f) (inst sr data length) (inst x accum data) DONE ;; Give it fixnum low-tag bits. (inst sl accum 3) (move result accum) ;; Make it positive. (inst sr result 1) (loadw lip csp-tn (* -1 word-bytes)) (inst dec csp-tn word-bytes) (inst sr lip 2) (inst cas lip lip code-tn)) cmucl-21a/src/assembly/rt/assem-rtns.lisp000066400000000000000000000244671260377556400206160ustar00rootroot00000000000000;;; -*- Package: RT; Log: c.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/rt/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/rt/assem-rtns.lisp $ ;;; (in-package "RT") ;;;; Non-local exit noise. (define-assembly-routine (unwind (:translate %continue-unwind) (:return-style :none) (:policy :fast-safe)) ((:arg block (word-pointer-reg any-reg descriptor-reg) a0-offset) (:arg start (word-pointer-reg any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg cname-offset) (:temp target-uwp any-reg lexenv-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst c block 0) (inst bc :eq error)) (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) (loadw target-uwp block unwind-block-current-uwp-slot) (inst c cur-uwp target-uwp) (inst bnc :eq do-uwp) (move cur-uwp block) DO-EXIT (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) (lisp-return lra lip :frob-code nil) DO-UWP (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) (inst bx do-exit) (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) (define-assembly-routine (throw (:return-style :none)) ((:arg target descriptor-reg a0-offset) (:arg start word-pointer-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset) (:temp ndescr non-descriptor-reg nl0-offset)) ;; These are needed by UNWIND, but not by us directly. (declare (ignore start count)) (load-symbol-value catch lisp::*current-catch-block*) LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst c catch 0) (inst bc :eq error)) (loadw tag catch catch-block-tag-slot) (inst c tag target) (inst bc :eq exit) (loadw catch catch catch-block-previous-catch-slot) (inst b loop) EXIT (move target catch) (inst cai ndescr (make-fixup 'unwind :assembly-routine)) (inst b ndescr)) ;;;; Return unknown multiple values (known not to be one value). (define-assembly-routine really-return-multiple ((:arg ocfp any-reg nl0-offset) (:arg lra descriptor-reg lra-offset) ;; Pointer into cstack, so looks like fixnum. (:arg src any-reg cname-offset) (:arg nvals any-reg nargs-offset) (:temp lip interior-reg lip-offset) (:temp count any-reg ocfp-offset) ;; Pointer into cstack, so looks like fixnum. (:temp dst any-reg lexenv-offset) (:temp temp any-reg nfp-offset) (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset)) ;; ;; Load the register args, bailing out when we are done. (inst c nvals 0) (inst bc :eq default-a0-and-on) (loadw a0 src 0) (inst c nvals (fixnumize 1)) (inst bc :eq default-a1-and-on) (loadw a1 src 1) (inst c nvals (fixnumize 2)) (inst bc :eq default-a2-and-on) (loadw a2 src 2) ;; ;; Copy the remaining args to the top of the stack. (inst inc src (* word-bytes register-arg-count)) (inst cal dst cfp-tn (* word-bytes register-arg-count)) (inst s count nvals (fixnumize 3)) (inst bnc :gt done) LOOP (loadw temp src) (inst inc src word-bytes) (storew temp dst) (inst inc dst word-bytes) (inst s count (fixnumize 1)) (inst bc :gt loop) (inst b done) ;; ;; Default some number of registers. DEFAULT-A0-AND-ON (move a0 null-tn) DEFAULT-A1-AND-ON (move a1 null-tn) DEFAULT-A2-AND-ON (move a2 null-tn) ;; ;; Clear the stack. DONE (move count cfp-tn) ;Put pointer to the start of values in ocfp. (inst cas csp-tn nvals count) ;Adjust the stack top: +. (move cfp-tn ocfp) ;Restore returnee's fp. ;; ;; Return. (lisp-return lra lip)) ;;;; Copying more args on call (known to be at least one more arg.) ;;; REALLY-COPY-MORE-ARGS -- Assembler Routine. ;;; ;;; This miscop has weird register usage conventions, since it is called at the ;;; very beginning of entry to a more-arg XEP. All of the registers used ;;; by the full call convention are in use, and must not be trashed, but none ;;; of the normal local & temporary registers are in use, since we haven't done ;;; anything yet. The number of fixed arguments is passed in a3, since we ;;; can't trash a0..a2. ;;; ;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1. ;;; The registers we can use are NL1, A3, L0 and L1. We save L2 and L3 to give ;;; us some more registers to work with. The caller saves the function return ;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return ;;; PC. ;;; ;;; What we do is fairly simple: we copy the incoming more arguments (index >= ;;; a3) onto the top of the stack. The loop runs backwards, since we are ;;; copying args upward on the stack, and the source and destination can ;;; overlap. ;;; ;;; This loop terminates when we either run out of more args to copy or we run ;;; out of stack arguments. If we run out of stack arguments before we finish, ;;; then there are register more args. In this case, we dispatch off of the ;;; number of fixed arguments (A3) to determine how many argument registers to ;;; store. ;;; (define-assembly-routine really-copy-more-args ;; Fixedargs contains the number of fixed arguments. ((:arg fixedargs any-reg cname-offset) (:temp count/src any-reg nfp-offset) (:temp ocsp any-reg nl0-offset) ;; Temporaries to get my hands on argument registers. (:temp a0 any-reg a0-offset) (:temp a1 any-reg a1-offset) (:temp a2 any-reg a2-offset) ;; We save the contents of these registers before ;; using them. (:temp srcstart any-reg lexenv-offset) (:temp dstend any-reg lra-offset) (:temp temp any-reg ocfp-offset)) ;; First, save count/src (the NFP) on the number stack. We need to do this ;; instead of with the other saves, because we need to use this register to ;; figure out where to save the others. We can't save them all there, ;; because some of the others hold descriptor values. (storew count/src nsp-tn -1) ;; How many more args are there to copy to the stack? (move count/src nargs-tn) (inst s count/src fixedargs) ;; Save the current stack top as the start of the more args. (move ocsp csp-tn) ;; Bump the stack by the number of more args. (inst cas csp-tn csp-tn count/src) ;; Bump the stack three for the registers we have to save. (inst cal csp-tn csp-tn (* 3 word-bytes)) ;; Dump the registers to make room for the temporaries we need. (storew srcstart csp-tn -3) (storew dstend csp-tn -2) (storew temp csp-tn -1) ;; Compute the source start, but remember we are copying from the end. ;; The start location is the last one we copy. (inst cal srcstart cfp-tn (* register-arg-count word-bytes)) ;; Compute the source location of the last more arg. (inst cas count/src nargs-tn cfp-tn) (inst dec count/src word-bytes) ;not an exclusive end. ;; Compute destination end, which is the stack pointer minus three register ;; slots we saved and minus one to make it an inclusive end. (inst cal dstend csp-tn (* -4 word-bytes)) ;; Copy some args. (inst b cma-test) CMA-LOOP (loadw temp count/src) (storew temp dstend) (inst dec count/src word-bytes) (inst dec dstend word-bytes) CMA-TEST ;; Are we totally done? (inst c dstend ocsp) (inst bc :lt CMA-DONE) ;; Are we done copying stack more args? (inst c count/src srcstart) (inst bnc :lt CMA-LOOP) ;; Figure out which argument registers may be more args. (inst c fixedargs (fixnumize 2)) (inst bc :eq two-fixed-args) (inst c fixedargs (fixnumize 1)) (inst bc :eq one-fixed-arg) ;; Copy register more args being careful to stop before running out of args. (storew a0 ocsp) (inst c nargs-tn (fixnumize 1)) (inst bc :eq CMA-DONE) (inst inc ocsp word-bytes) ONE-FIXED-ARG (storew a1 ocsp) (inst c nargs-tn (fixnumize 2)) (inst bc :eq CMA-DONE) (inst inc ocsp word-bytes) TWO-FIXED-ARGS (storew a2 ocsp) ;; Restore registers we dumped. CMA-DONE (loadw srcstart csp-tn -3) (loadw dstend csp-tn -2) (loadw temp csp-tn -1) (inst dec csp-tn (* 3 word-bytes)) (loadw count/src nsp-tn -1) (inst b lip-tn)) ;;;; Tail call variable. (define-assembly-routine (really-tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) ;; These are needed by the blitting code. (:temp count any-reg lra-offset) (:temp dst any-reg lexenv-offset) (:temp nargs any-reg nargs-offset) (:temp temp descriptor-reg cname-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset)) ;; Calculate NARGS (as a fixnum). (move nargs csp-tn) (inst s nargs args) ;; Load the argument registers now because the argument moving might trash ;; these locations. (loadw a0 args 0) (loadw a1 args 1) (loadw a2 args 2) ;; Are we done? (inst c nargs (fixnumize register-arg-count)) (inst bnc :gt done) ;; Calc DST and COUNT after saving those registers. (inst inc csp-tn (* word-bytes 2)) (storew count csp-tn -1) (storew dst csp-tn -2) (inst a count nargs (fixnumize (- register-arg-count))) (inst a args (* vm:word-bytes register-arg-count)) (inst a dst cfp-tn (* vm:word-bytes register-arg-count)) LOOP ;; Copy one arg. (loadw temp args) (inst inc args vm:word-bytes) (storew temp dst) (inst s count (fixnumize 1)) (inst bcx :gt loop) (inst inc dst vm:word-bytes) ;; Restore (loadw count csp-tn -1) (loadw dst csp-tn -2) (inst dec csp-tn (* word-bytes 2)) DONE ;; We are done. Do the jump. (loadw temp dst vm:closure-function-slot vm:function-pointer-type) (lisp-jump temp lip-tn)) cmucl-21a/src/assembly/rt/support.lisp000066400000000000000000000043631260377556400202270ustar00rootroot00000000000000;;; -*- Package: RT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/rt/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/rt/support.lisp $ ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; (in-package "RT") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (values `((inst bala (make-fixup ',name :assembly-routine))) nil)) (:full-call (let ((nfp-save (make-symbol "NFP-SAVE")) (lra (make-symbol "LRA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn cur-nfp ,nfp-save)) (inst compute-lra-from-code ,lra code-tn lra-label) ;; This absolute branch trashes the LIP register, but we don't use ;; it when calling assembly routines. (inst bala (make-fixup ',name :assembly-routine)) (emit-return-pc lra-label) (note-this-location ,vop :unknown-return) ;; Don't use MOVE. Use a known 32-bit long instruction, so the ;; returner can know how many bytes we used here in the ;; multiple-value return case. The returner wants to add a known ;; quantity to LRA indicating how many values it returned. (inst cal csp-tn ocfp-tn 0) (inst compute-code-from-lra code-tn code-tn lra-label) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save))))) (:none (values ;; This absolute branch trashes the LIP register, but we don't use it ;; when calling assembly routines. `((inst bala (make-fixup ',name :assembly-routine))) nil)))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst b lip-tn))) (:full-call `((lisp-return lra-tn lip-tn :offset 1))) (:none))) cmucl-21a/src/assembly/sparc/000077500000000000000000000000001260377556400162775ustar00rootroot00000000000000cmucl-21a/src/assembly/sparc/alloc.lisp000066400000000000000000000011031260377556400202550ustar00rootroot00000000000000;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/sparc/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocating simple objects. ;;; ;;; Written by William Lott. ;;; (in-package "SPARC") ;;; But we do everything inline now that we have a better pseudo-atomic. cmucl-21a/src/assembly/sparc/arith.lisp000066400000000000000000000243331260377556400203040ustar00rootroot00000000000000;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/sparc/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; (in-package "SPARC") ;;;; Addition and subtraction. (define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) (:translate +) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst nop) (inst addcc temp x y) (inst b :vc done) (inst nop) (inst sra temp x fixnum-tag-bits) (inst sra temp2 y fixnum-tag-bits) (inst add temp2 temp) (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) (lisp-return lra :offset 2) DO-STATIC-FUN (inst ld code-tn null-tn (static-function-offset 'two-arg-+)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) DONE (move res temp)) (define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) (:translate -) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst nop) (inst subcc temp x y) (inst b :vc done) (inst nop) (inst sra temp x fixnum-tag-bits) (inst sra temp2 y fixnum-tag-bits) (inst sub temp2 temp temp2) (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-type)) (lisp-return lra :offset 2) DO-STATIC-FUN (inst ld code-tn null-tn (static-function-offset 'two-arg--)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) DONE (move res temp)) ;;;; Multiplication (define-assembly-routine (generic-* (:cost 50) (:return-style :full-call) (:translate *) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res (descriptor-reg any-reg) a0-offset) (:temp temp non-descriptor-reg nl0-offset) (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst nop) ;; Remove the tag from one arg so that the result will have the correct ;; fixnum tag. (inst sra temp x fixnum-tag-bits) ;; Compute the produce temp * y and return the double-word product ;; in hi:lo. (cond ((backend-featurep :sparc-64) ;; Sign extend y to a full 64-bits. temp was already ;; sign-extended by the sra instruction above. (inst sra y 0) (inst mulx hi temp y) (inst move lo hi) (inst srax hi 32)) ((or (backend-featurep :sparc-v8) (backend-featurep :sparc-v9)) (inst smul lo temp y) (inst rdy hi)) (t (let ((MULTIPLIER-POSITIVE (gen-label))) (inst wry temp) (inst andcc hi zero-tn) (inst nop) (inst nop) (dotimes (i 32) (inst mulscc hi y)) (inst mulscc hi zero-tn) (inst cmp x) (inst b :ge MULTIPLIER-POSITIVE) (inst nop) (inst sub hi y) (emit-label MULTIPLIER-POSITIVE) (inst rdy lo)))) ;; Check to see if the result will fit in a fixnum. (I.e. the high word ;; is just 32 copies of the sign bit of the low word). (inst sra temp lo 31) (inst xorcc temp hi) (inst b :eq LOW-FITS-IN-FIXNUM) ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag. (inst sll temp hi 30) (inst srl lo fixnum-tag-bits) (inst or lo temp) (inst sra hi fixnum-tag-bits) ;; Allocate a BIGNUM for the result. We always allocate 2 words for ;; the bignum result, even if we only need one. The copying GC will ;; take care of the extra word if it isn't needed. (with-fixed-allocation (res temp bignum-type (+ 2 bignum-digits-offset)) (let ((one-word (gen-label))) ;; We start out assuming that we need one word. Is that correct? (inst sra temp lo 31) (inst xorcc temp hi) (inst b :eq one-word) (inst li temp (logior (ash 1 type-bits) bignum-type)) ;; Need 2 words. Set the header appropriately, and save the ;; high and low parts. (inst li temp (logior (ash 2 type-bits) bignum-type)) (storew hi res (1+ bignum-digits-offset) other-pointer-type) (emit-label one-word) (storew temp res 0 other-pointer-type) (storew lo res bignum-digits-offset other-pointer-type))) ;; Out of here (lisp-return lra :offset 2) DO-STATIC-FUN (inst ld code-tn null-tn (static-function-offset 'two-arg-*)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) LOW-FITS-IN-FIXNUM (move res lo)) ;;;; Comparison (macrolet ((define-cond-assem-rtn (name translate static-fn cmp) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :eq DO-COMPARE) (inst cmp x y) DO-STATIC-FN (inst ld code-tn null-tn (static-function-offset ',static-fn)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) DO-COMPARE (inst b ,cmp done) (load-symbol res t) (inst move res null-tn) DONE))) (define-cond-assem-rtn generic-< < two-arg-< :lt) (define-cond-assem-rtn generic-<= <= two-arg-<= :le) (define-cond-assem-rtn generic-> > two-arg-> :gt) (define-cond-assem-rtn generic->= >= two-arg->= :ge)) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst cmp x y) (inst b :eq RETURN-T) (inst andcc zero-tn x fixnum-tag-mask) (inst b :eq RETURN-NIL) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst nop) RETURN-NIL (inst move res null-tn) (lisp-return lra :offset 2) DO-STATIC-FN (inst ld code-tn null-tn (static-function-offset 'eql)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst cmp x y) (inst b :eq RETURN-T) (inst nop) (inst move res null-tn) (lisp-return lra :offset 2) DO-STATIC-FN (inst ld code-tn null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-/= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate /=) (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) (:res res descriptor-reg a0-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) (inst cmp x y) (inst b :eq RETURN-NIL) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst andcc zero-tn y fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst nop) (load-symbol res t) (lisp-return lra :offset 2) DO-STATIC-FN (inst ld code-tn null-tn (static-function-offset 'two-arg-=)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst move cfp-tn csp-tn) RETURN-NIL (inst move res null-tn)) cmucl-21a/src/assembly/sparc/array.lisp000066400000000000000000000116701260377556400203130ustar00rootroot00000000000000;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/sparc/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/sparc/array.lisp $ ;;; ;;; This file contains the support routines for arrays and vectors. ;;; ;;; Written by William Lott. ;;; (in-package "SPARC") (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) (:temp ndescr non-descriptor-reg nl0-offset) (:temp gc-temp non-descriptor-reg nl1-offset) (:temp vector descriptor-reg a3-offset)) (pseudo-atomic () (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) (inst andn ndescr vm:lowtag-mask) (allocation vector ndescr other-pointer-type :temp-tn gc-temp) #+gencgc (progn ;; ndescr points to one word past the end of the allocated ;; space. Fill the last word with a zero. (inst add ndescr vector) (storew zero-tn ndescr -1 vm:other-pointer-type)) (inst srl ndescr type vm:word-shift) (storew ndescr vector 0 vm:other-pointer-type) (storew length vector vm:vector-length-slot vm:other-pointer-type)) ;; This makes sure the zero byte at the end of a string is paged in so ;; the kernel doesn't bitch if we pass it the string. ;; ;; This used to write to the word after the last allocated word. I ;; (RLT) made it write to the last allocated word, which is where ;; the zero-byte of the string is. Look at the deftransform for ;; make-array in array-tran.lisp. For strings we always allocate ;; enough space to hold the zero-byte. #-gencgc (storew zero-tn alloc-tn -1) (move result vector)) ;;;; Hash primitives #+assembler (defparameter sxhash-simple-substring-entry (gen-label)) (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:res result any-reg a0-offset) (:temp length any-reg a1-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp temp non-descriptor-reg nl2-offset) (:temp offset non-descriptor-reg nl3-offset)) (declare (ignore result accum data temp offset)) (inst b sxhash-simple-substring-entry) (loadw length string vm:vector-length-slot vm:other-pointer-type)) ;; Implement the one-at-a-time algorithm designed by Bob Jenkins ;; (see for some ;; more information). ;; ;; For completeness, here is the hash function, in C, from that web ;; page. ub4 is an unsigned 32-bit integer. #|| ub4 one_at_a_time(char *key, ub4 len) { ub4 hash, i; for (hash=0, i=0; i> 6); } hash += (hash << 3); hash ^= (hash >> 11); hash += (hash << 15); return (hash & mask); } ||# (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) (:temp accum non-descriptor-reg nl0-offset) (:temp data non-descriptor-reg nl1-offset) (:temp temp non-descriptor-reg nl2-offset) (:temp offset non-descriptor-reg nl3-offset)) (emit-label sxhash-simple-substring-entry) #+unicode (inst sll length 1) ; Number of bytes = twice the length (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type)) (inst b test) (move accum zero-tn) LOOP ;; hash += key[i] (inst add accum data) ;; hash += (hash << 10) (inst slln temp accum 10) (inst add accum temp) ;; hash ^= (hash >> 6) (inst srln temp accum 6) (inst xor accum temp) (inst add offset 1) TEST (inst subcc length (fixnumize 1)) (inst b :ge loop) (inst ldub data string offset) ;; hash += (hash << 3) (inst slln temp accum 3) (inst add accum temp) ;; hash ^= (hash >> 11) (inst srln temp accum 11) (inst xor accum temp) ;; hash += (hash << 15) (inst slln temp accum 15) (inst add accum temp) ;;(inst li temp most-positive-fixnum) ;;(inst and accum temp) ;; Make it a fixnum result ;; Make the result a positive fixnum. Shifting it left, then right ;; does what we want, and extracts the bits we need. (inst slln accum (1+ vm:fixnum-tag-bits)) (inst srln result accum 1)) cmucl-21a/src/assembly/sparc/assem-rtns.lisp000066400000000000000000000216601260377556400212710ustar00rootroot00000000000000;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/sparc/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/assembly/sparc/assem-rtns.lisp $ ;;; ;;; (in-package "SPARC") ;;;; Return-multiple with other than one value #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) ;; These four are really arguments. ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl0-offset) (:temp ocfp any-reg nl1-offset) (:temp lra descriptor-reg lra-offset) ;; These are just needed to facilitate the transfer (:temp count any-reg nl2-offset) (:temp src any-reg nl3-offset) (:temp dst any-reg nl4-offset) (:temp temp descriptor-reg cname-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Note, because of the way the return-multiple vop is written, we can ;; assume that we are never called with nvals == 1 and that a0 has already ;; been loaded. (inst cmp nvals) (inst b :le default-a0-and-on) (inst cmp nvals (fixnumize 2)) (inst b :le default-a2-and-on) (inst ld a1 vals (* 1 vm:word-bytes)) (inst cmp nvals (fixnumize 3)) (inst b :le default-a3-and-on) (inst ld a2 vals (* 2 vm:word-bytes)) (inst cmp nvals (fixnumize 4)) (inst b :le default-a4-and-on) (inst ld a3 vals (* 3 vm:word-bytes)) (inst cmp nvals (fixnumize 5)) (inst b :le default-a5-and-on) (inst ld a4 vals (* 4 vm:word-bytes)) (inst cmp nvals (fixnumize 6)) (inst b :le done) (inst ld a5 vals (* 5 vm:word-bytes)) ;; Copy the remaining args to the top of the stack. (inst add src vals (* 6 vm:word-bytes)) (inst add dst cfp-tn (* 6 vm:word-bytes)) (inst subcc count nvals (fixnumize 6)) LOOP (inst ld temp src) (inst add src vm:word-bytes) (inst st temp dst) (inst add dst vm:word-bytes) (inst b :gt loop) (inst subcc count (fixnumize 1)) (inst b done) (inst nop) DEFAULT-A0-AND-ON (inst move a0 null-tn) (inst move a1 null-tn) DEFAULT-A2-AND-ON (inst move a2 null-tn) DEFAULT-A3-AND-ON (inst move a3 null-tn) DEFAULT-A4-AND-ON (inst move a4 null-tn) DEFAULT-A5-AND-ON (inst move a5 null-tn) DONE ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst add csp-tn ocfp-tn nvals) ;; Return. (lisp-return lra)) ;;;; tail-call-variable. #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ;; These are really args. ((:temp args any-reg nl0-offset) (:temp lexenv descriptor-reg lexenv-offset) ;; We need to compute this (:temp nargs any-reg nargs-offset) ;; These are needed by the blitting code. (:temp src any-reg nl1-offset) (:temp dst any-reg nl2-offset) (:temp count any-reg nl3-offset) (:temp temp descriptor-reg cname-offset) ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) (:temp a3 descriptor-reg a3-offset) (:temp a4 descriptor-reg a4-offset) (:temp a5 descriptor-reg a5-offset)) ;; Calculate NARGS (as a fixnum) (inst sub nargs csp-tn args) ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst ld a0 args (* 0 vm:word-bytes)) (inst ld a1 args (* 1 vm:word-bytes)) (inst ld a2 args (* 2 vm:word-bytes)) (inst ld a3 args (* 3 vm:word-bytes)) (inst ld a4 args (* 4 vm:word-bytes)) (inst ld a5 args (* 5 vm:word-bytes)) ;; Calc SRC, DST, and COUNT (inst addcc count nargs (fixnumize (- register-arg-count))) (inst b :le done) (inst add src args (* vm:word-bytes register-arg-count)) (inst add dst cfp-tn (* vm:word-bytes register-arg-count)) LOOP ;; Copy one arg. (inst ld temp src) (inst add src src vm:word-bytes) (inst st temp dst) (inst addcc count (fixnumize -1)) (inst b :gt loop) (inst add dst dst vm:word-bytes) DONE ;; We are done. Do the jump. (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type) (lisp-jump temp)) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:return-style :none) (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) a0-offset) (:arg start (any-reg descriptor-reg) ocfp-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp lra descriptor-reg lra-offset) (:temp cur-uwp any-reg nl0-offset) (:temp next-uwp any-reg nl1-offset) (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst cmp block) (inst b :eq error)) (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) (loadw target-uwp block vm:unwind-block-current-uwp-slot) (inst cmp cur-uwp target-uwp) (inst b :ne do-uwp) (inst nop) (move cur-uwp block) DO-EXIT (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot) (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) (loadw lra cur-uwp vm:unwind-block-entry-pc-slot) (lisp-return lra :frob-code nil) DO-UWP (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) (inst b do-exit) (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) (define-assembly-routine (throw (:return-style :none)) ((:arg target descriptor-reg a0-offset) (:arg start any-reg ocfp-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset) (:temp temp non-descriptor-reg nl0-offset)) (declare (ignore start count)) (load-symbol-value catch lisp::*current-catch-block*) loop (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst cmp catch) (inst b :eq error) (inst nop)) (loadw tag catch vm:catch-block-tag-slot) (inst cmp tag target) (inst b :eq exit) (inst nop) (loadw catch catch vm:catch-block-previous-catch-slot) (inst b loop) (inst nop) exit (move target catch) (inst li temp (make-fixup 'unwind :assembly-routine)) (inst j temp) (inst nop)) ;; Assembly routines for undefined_tramp and closure_tramp #+assembler (define-assembly-routine (closure-tramp-function-alignment (:return-style :none)) () ;; Align to a dualword and put in the magic function header stuff so ;; that closure-tramp looks like a normal function with a function ;; tag. (align vm:lowtag-bits) (inst byte 0)) #+assembler (define-assembly-routine (closure-tramp (:return-style :none)) () (inst byte 0) (inst byte 0) (inst byte vm:function-header-type) ;; This is supposed to be closure-tramp, not 0. (inst word 0) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (loadw lexenv-tn cname-tn fdefn-function-slot other-pointer-type) (loadw code-tn lexenv-tn closure-function-slot function-pointer-type) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst nop) ;; Make sure following routine is dual-word aligned (align vm:lowtag-bits)) #+assembler (define-assembly-routine (undefined-tramp-function-alignment (:return-style :none)) () ;; Align to a dualword and put in the magic function header stuff so ;; that closure-tramp looks like a normal function with a function ;; tag. (align vm:lowtag-bits) (inst byte 0)) #+assembler (define-assembly-routine (undefined-tramp (:return-style :none)) () (inst byte 0) (inst byte 0) (inst byte vm:function-header-type) ;; This is supposed to be undefined-tramp, not 0. (inst word 0) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (inst word (kernel:get-lisp-obj-address nil)) (let ((error (generate-cerror-code nil undefined-symbol-error cname-tn))) (inst b error) (inst nop) ;; I don't think we ever return from the undefined-symbol-error ;; handler, but the assembly code did this so we'll do it too. (loadw code-tn cname-tn fdefn-raw-addr-slot other-pointer-type) (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type)) (inst nop))) cmucl-21a/src/assembly/sparc/support.lisp000066400000000000000000000047711260377556400207150ustar00rootroot00000000000000;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/assembly/sparc/support.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "SPARC") (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (let ((temp (make-symbol "TEMP")) (lip (make-symbol "LIP"))) (values `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine)) (inst nop)) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) ,lip))))) (:full-call (let ((temp (make-symbol "TEMP")) (nfp-save (make-symbol "NFP-SAVE")) (lra (make-symbol "LRA"))) (values `((let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn ,vop))) (when cur-nfp (store-stack-tn ,nfp-save cur-nfp)) (inst compute-lra-from-code ,lra code-tn lra-label ,temp) (note-next-instruction ,vop :call-site) (inst ji ,temp (make-fixup ',name :assembly-routine)) (inst nop) (emit-return-pc lra-label) (note-this-location ,vop :single-value-return) (without-scheduling () (move csp-tn ocfp-tn) (inst nop)) (inst compute-code-from-lra code-tn code-tn lra-label ,temp) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp) (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 0) :to (:eval 1)) ,lra) (:temporary (:scs (control-stack) :offset nfp-save-offset) ,nfp-save) (:save-p :compute-only))))) (:none (let ((temp (make-symbol "TEMP"))) (values `((inst ji ,temp (make-fixup ',name :assembly-routine)) (inst nop)) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) ,temp))))))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst j (make-random-tn :kind :normal :sc (sc-or-lose 'interior-reg *backend*) :offset lip-offset) 8) (inst nop))) (:full-call `((lisp-return (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg *backend*) :offset lra-offset) :offset 2))) (:none))) cmucl-21a/src/assembly/x86/000077500000000000000000000000001260377556400156145ustar00rootroot00000000000000cmucl-21a/src/assembly/x86/alloc.lisp000066400000000000000000000013601260377556400175770ustar00rootroot00000000000000;;; -*- Package: X86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/x86/alloc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle allocating simple objects. ;;; ;;; Written by William Lott. ;;; ;;; Debugged by Paul F. Werkowski -- Spring 1995. ;;; (in-package "X86") ;;; But we do everything inline now that we have a better pseudo-atomic. cmucl-21a/src/assembly/x86/arith.lisp000066400000000000000000000270541260377556400176240ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/x86/arith.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to handle simple cases for generic arithmetic. ;;; ;;; Written by William Lott. ;;; Debugged by Paul Werkowski -- Spring/Summer 1995. ;;; (in-package :x86) (eval-when (compile eval) ;;;; Addition, Subtraction, and Multiplication (defmacro define-generic-arith-routine ((fun cost) &body body) `(define-assembly-routine (,(symbolicate "GENERIC-" fun) (:cost ,cost) (:return-style :full-call) (:translate ,fun) (:policy :safe) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) ;; this seems wrong esi-offset edi-offset) (:res res (descriptor-reg any-reg) edx-offset) (:temp eax unsigned-reg eax-offset) (:temp ebx unsigned-reg ebx-offset) (:temp ecx unsigned-reg ecx-offset)) (declare (ignorable ebx)) (inst test x 3) ; fixnum? (inst jmp :nz DO-STATIC-FUN) ; no - do generic (inst test y 3) ; fixnum? (inst jmp :z DO-BODY) ; yes - doit here DO-STATIC-FUN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) ; callers return addr (inst mov ecx (fixnumize 2)) ; arg count (inst jmp (make-ea :dword :disp (+ nil-value (static-function-offset ',(symbolicate "TWO-ARG-" fun))))) DO-BODY ,@body)) ); eval-when (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no OKAY) (inst rcr res 1) ; carry has correct sign (inst sar res 1) ; remove type bits (move ecx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset)) (storew ecx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (- 10) ;;; I can't figure out the flags on subtract. Overflow never gets ;;; set and carry always does. (- 0 most-negative-fixnum) can't be ;;; easily detected so just let the upper level stuff do it. (inst jmp DO-STATIC-FUN) (move res x) (inst sub res y) (inst jmp :no OKAY) (inst rcr res 1) (inst sar res 1) ; remove type bits (move ecx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset)) (storew ecx res bignum-digits-offset other-pointer-type)) OKAY) (define-generic-arith-routine (* 30) (move eax x) ; must use eax for 64-bit result (inst sar eax 2) ; remove *4 fixnum bias (inst imul y) ; result in edx:eax (inst jmp :no okay) ; still fixnum ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above ;; pfw says that loses big -- edx is target for arg x and result res ;; note that 'edx' is not defined -- using x (inst shrd eax x 2) ; high bits from edx (inst sar x 2) ; now shift edx too (move ecx x) ; save high bits from cdq (inst cdq) ; edx:eax <- sign-extend of eax (inst cmp x ecx) (inst jmp :e SINGLE-WORD-BIGNUM) (with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2)) (storew eax res bignum-digits-offset other-pointer-type) (storew ecx res (1+ bignum-digits-offset) other-pointer-type)) (inst jmp DONE) SINGLE-WORD-BIGNUM (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset)) (storew eax res bignum-digits-offset other-pointer-type)) (inst jmp DONE) OKAY (move res eax) DONE) (define-assembly-routine (generic-negate (:cost 10) (:return-style :full-call) (:policy :safe) (:translate %negate) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:res res (descriptor-reg any-reg) edx-offset) (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst test x 3) (inst jmp :z FIXNUM) (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) (inst mov ecx (fixnumize 1)) ; arg count (inst jmp (make-ea :dword :disp (+ nil-value (static-function-offset '%negate)))) FIXNUM (move res x) (inst neg res) ; (- most-negative-fixnum) is BIGNUM (inst jmp :no OKAY) (inst shr res 2) ; sign bit is data - remove type bits (move ecx res) (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset)) (storew ecx res bignum-digits-offset other-pointer-type)) OKAY) ;;;; Comparison routines. (eval-when (compile eval) (defmacro define-cond-assem-rtn (name translate static-fn test) `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) (:policy :safe) (:translate ,translate) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) (:res res descriptor-reg edx-offset) (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst test x 3) (inst jmp :nz DO-STATIC-FN) (inst test y 3) (inst jmp :z DO-COMPARE) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-function-offset ',static-fn)))) DO-COMPARE (inst cmp x y) (inst jmp ,test TRUE) (inst mov res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) TRUE (load-symbol res t))) ); eval-when (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g) (define-assembly-routine (generic-eql (:cost 10) (:return-style :full-call) (:policy :safe) (:translate eql) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) (:res res descriptor-reg edx-offset) (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 3) (inst jmp :z RETURN-NIL) (inst test y 3) (inst jmp :nz DO-STATIC-FN) RETURN-NIL (inst mov res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-function-offset 'eql)))) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) (:policy :safe) (:translate =) (:save-p t)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) (:res res descriptor-reg edx-offset) (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset) ) (inst test x 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) ; yes do it here (inst test y 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) (inst cmp x y) (inst jmp :e RETURN-T) ; ok (inst mov res nil-value) (inst pop eax) (inst add eax 2) (inst jmp eax) DO-STATIC-FN (inst pop eax) (inst push ebp-tn) (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-function-offset 'two-arg-=)))) RETURN-T (load-symbol res t)) ;;; Support for the Mersenne Twister, MT19937, random number generator ;;; due to Matsumoto and Nishimura. ;;; ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A ;;; 623-dimensionally equidistributed uniform pseudorandom number ;;; generator.", ACM Transactions on Modeling and Computer Simulation, ;;; 1997, to appear. ;;; ;;; State: ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) ;;; 2: Index; init. to 1. ;;; 3-626: State. ;;; ;;; This assembly routine is called from the inline VOP and updates ;;; the state vector with new random numbers. The state vector is ;;; passed in the EAX register. ;;; #+assembler ; we don't want a vop for this one. (define-assembly-routine (random-mt19937-update) ((:temp state unsigned-reg eax-offset) (:temp k unsigned-reg ebx-offset) (:temp y unsigned-reg ecx-offset) (:temp tmp unsigned-reg edx-offset)) ;; Save the temporary registers. (inst push k) (inst push y) (inst push tmp) ;; Generate a new set of results. (inst xor k k) LOOP1 (inst mov y (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 1 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip1) (inst xor y #x9908b0df) SKIP1 (inst xor y (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 397 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) (inst inc k) (inst cmp k (- 624 397)) (inst jmp :b loop1) LOOP2 (inst mov y (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 1 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip2) (inst xor y #x9908b0df) SKIP2 (inst xor y (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ (- 397 624) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :dword :base state :index k :scale 4 :disp (- (* (+ 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) (inst inc k) (inst cmp k (- 624 1)) (inst jmp :b loop2) (inst mov y (make-ea :dword :base state :disp (- (* (+ (- 624 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov tmp (make-ea :dword :base state :disp (- (* (+ 0 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) (inst shr y 1) (inst jmp :nc skip3) (inst xor y #x9908b0df) SKIP3 (inst xor y (make-ea :dword :base state :disp (- (* (+ (- 397 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type))) (inst mov (make-ea :dword :base state :disp (- (* (+ (- 624 1) 3 vm:vector-data-offset) vm:word-bytes) vm:other-pointer-type)) y) ;; Restore the temporary registers and return. (inst pop tmp) (inst pop y) (inst pop k) (inst ret)) cmucl-21a/src/assembly/x86/array.lisp000066400000000000000000000073061260377556400176310ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/x86/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains various array operations that are too expensive ;;; (in space) to do inline. ;;; ;;; Written by William Lott. ;;; ;;; Debugged by Paul F. Werkowski -- Spring 1995. ;;; (in-package :x86) ;;;; Allocation (define-assembly-routine (allocate-vector (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) ((:arg type unsigned-reg eax-offset) (:arg length any-reg ebx-offset) (:arg words any-reg ecx-offset) (:res result descriptor-reg edx-offset)) (inst mov result (+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes))) (inst add result words) (inst and result (lognot vm:lowtag-mask)) (pseudo-atomic (allocation result result) (inst lea result (make-ea :byte :base result :disp other-pointer-type)) (storew type result 0 other-pointer-type) (storew length result vector-length-slot other-pointer-type)) (inst ret)) ;;;; Hash primitives (define-assembly-routine (sxhash-simple-string (:translate %sxhash-simple-string) (:policy :fast-safe) (:result-types positive-fixnum)) ((:arg string descriptor-reg ebx-offset) (:res result any-reg edx-offset) (:temp length any-reg edi-offset) (:temp esi unsigned-reg esi-offset) (:temp ecx unsigned-reg ecx-offset) (:temp eax unsigned-reg eax-offset)) (declare (ignore result esi ecx eax)) (loadw length string vector-length-slot other-pointer-type) (inst jmp (make-fixup 'sxhash-simple-substring :assembly-routine))) (define-assembly-routine (sxhash-simple-substring (:translate %sxhash-simple-substring) (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) ((:arg string descriptor-reg ebx-offset) (:arg length any-reg edi-offset) (:res result any-reg edx-offset) (:temp esi unsigned-reg esi-offset) (:temp ecx unsigned-reg ecx-offset) (:temp eax unsigned-reg eax-offset)) ;; Compute a pointer to where we are going to be extracting the bits. (inst lea esi (make-ea :byte :base string :disp (- (* vector-data-offset word-bytes) other-pointer-type))) #+unicode (inst shl length 1) ; Number of bytes = twice the length ;; Initialize the result. (inst xor result result) ;; Get the count. If it's zero, blow out. (inst mov ecx length) (inst jecxz done) (inst shr ecx 2) ; Convert fixnum to byte count LOOP ;; Merge each successive word with the result. (inst movzx eax (make-ea :byte :base esi-tn)) (inst inc esi) ;; hash += key[i] (inst add result eax) ;; hash += (hash << 10) (move eax result) (inst shl eax 10) (inst add result eax) ;; hash ^= (hash >> 6) (move eax result) (inst shr eax 6) (inst xor result eax) (inst loop loop) ;; hash += (hash << 3) (move eax result) (inst shl eax 3) (inst add result eax) ;; hash ^= (hash >> 11) (move eax result) (inst shr eax 11) (inst xor result eax) ;; hash += (hash << 15) (move eax result) (inst shl eax 15) (inst add result eax) DONE ;; Force result to be a positive fixnum. (inst and result #x7ffffffc) (inst ret)) cmucl-21a/src/assembly/x86/assem-rtns.lisp000066400000000000000000000216461260377556400206120ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/x86/assem-rtns.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; ;;; Written by William Lott ;;; ;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995. ;;; Enhancements/debugging by Douglas T. Crosher 1997. ;;; (in-package :x86) ;;;; Return-multiple ;;; For return-multiple, we have to move the results from the end of the ;;; frame for the function that is returning to the end of the frame for ;;; the function being returned to. #+assembler ;; we don't want a vop for this one. (define-assembly-routine (return-multiple (:return-style :none)) (;; These four are really arguments. (:temp eax unsigned-reg eax-offset) (:temp ebx unsigned-reg ebx-offset) (:temp ecx unsigned-reg ecx-offset) (:temp esi unsigned-reg esi-offset) ;; These we need as temporaries. (:temp edx unsigned-reg edx-offset) (:temp edi unsigned-reg edi-offset)) ;; Pick off the cases where everything fits in register args. (inst jecxz zero-values) (inst cmp ecx (fixnumize 1)) (inst jmp :e one-value) (inst cmp ecx (fixnumize 2)) (inst jmp :e two-values) (inst cmp ecx (fixnumize 3)) (inst jmp :e three-values) ;; Save the count, because the loop is going to destroy it. (inst mov edx ecx) ;; Blit the values down the stack. Note: there might be overlap, so we have ;; to be careful not to clobber values before we've read them. Because the ;; stack builds down, we are copying to a larger address. Therefore, we need ;; to iterate from larger addresses to smaller addresses. ;; pfw-this says copy ecx words from esi to edi counting down. (inst shr ecx 2) ; fixnum to raw word count (inst sub esi 4) ; ? (inst lea edi (make-ea :dword :base ebx :disp (- word-bytes))) (inst std) ; count down (inst rep) (inst movs :dword) (inst cld) ;; Restore the count. (inst mov ecx edx) ;; Set the stack top to the last result. (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)) ;; Load the register args. (loadw edx ebx -1) (loadw edi ebx -2) (loadw esi ebx -3) ;; And back we go. (inst jmp eax) ;; Handle the register arg cases. ZERO-VALUES (move esp-tn ebx) (inst mov edx nil-value) (inst mov edi edx) (inst mov esi edx) (inst jmp eax) ONE-VALUE ; Note: we can get this, because the return-multiple vop ; doesn't check for this case when size > speed. (loadw edx esi -1) (inst mov esp-tn ebx) (inst add eax 2) (inst jmp eax) TWO-VALUES (loadw edx esi -1) (loadw edi esi -2) (inst mov esi nil-value) (inst lea esp-tn (make-ea :dword :base ebx :disp (* -2 word-bytes))) (inst jmp eax) THREE-VALUES (loadw edx esi -1) (loadw edi esi -2) (loadw esi esi -3) (inst lea esp-tn (make-ea :dword :base ebx :disp (* -3 word-bytes))) (inst jmp eax)) ;;;; tail-call-variable. ;;; For tail-call-variable, we have to copy the arguments from the end of our ;;; stack frame (where args are produced) to the start of our stack frame ;;; (where args are expected). ;;; ;;; We take the function to call in EAX and a pointer to the arguments in ;;; ESI. EBP stays the same over the jump, and the old frame pointer is ;;; still saved in the first stack slot. The return-pc is saved in ;;; the second stack slot, so we have to push it to make it look like ;;; we actually called. We also have to compute ECX from the difference ;;; between ESI and the stack top. ;;; #+assembler ;; no vop for this one either. (define-assembly-routine (tail-call-variable (:return-style :none)) ((:temp eax unsigned-reg eax-offset) (:temp ebx unsigned-reg ebx-offset) (:temp ecx unsigned-reg ecx-offset) (:temp edx unsigned-reg edx-offset) (:temp edi unsigned-reg edi-offset) (:temp esi unsigned-reg esi-offset)) ;; Calculate NARGS (as a fixnum) (move ecx esi) (inst sub ecx esp-tn) ;; Check for all the args fitting in the registers. (inst cmp ecx (fixnumize 3)) (inst jmp :le REGISTER-ARGS) ;; Save the OLD-FP and RETURN-PC because the blit is going to trash ;; those stack locations. Save the ECX, because the loop is going ;; to trash it. (pushw ebp-tn -1) (loadw ebx ebp-tn -2) (inst push ecx) ;; Do the blit. Because we are copying from smaller addresses to larger ;; addresses, we have to start at the largest pair and work our way down. (inst shr ecx 2) ; fixnum to raw words (inst lea edi (make-ea :dword :base ebp-tn :disp (- word-bytes))) (inst sub esi (fixnumize 1)) (inst std) ; count down (inst rep) (inst movs :dword) (inst cld) ;; Load the register arguments carefully. (loadw edx ebp-tn -1) ;; Restore OLD-FP and ECX. (inst pop ecx) (popw ebp-tn -1) ; overwrites a0 ;; Blow off the stack above the arguments. (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)) ;; remaining register args (loadw edi ebp-tn -2) (loadw esi ebp-tn -3) ;; Push the (saved) return-pc so it looks like we just called. (inst push ebx) ;; And jump into the function. (inst jmp (make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes) function-pointer-type))) ;; All the arguments fit in registers, so load them. REGISTER-ARGS (loadw edx esi -1) (loadw edi esi -2) (loadw esi esi -3) ;; Clear most of the stack. (inst lea esp-tn (make-ea :dword :base ebp-tn :disp (* -3 word-bytes))) ;; Push the return-pc so it looks like we just called. (pushw ebp-tn -2) ;; And away we go. (inst jmp (make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes) function-pointer-type)))) (define-assembly-routine (throw (:return-style :none)) ((:arg target (descriptor-reg any-reg) edx-offset) (:arg start any-reg ebx-offset) (:arg count any-reg ecx-offset) (:temp catch any-reg eax-offset)) (declare (ignore start count)) (load-symbol-value catch lisp::*current-catch-block*) LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst or catch catch) ; check for NULL pointer (inst jmp :z error)) (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) (inst jmp :e exit) (loadw catch catch catch-block-previous-catch-slot) (inst jmp loop) EXIT ;; Here EAX points to catch block containing symbol pointed to by EDX. (inst jmp (make-fixup 'unwind :assembly-routine))) ;;;; Non-local exit noise. (define-assembly-routine (unwind (:return-style :none) (:translate %continue-unwind) (:policy :fast-safe)) ((:arg block (any-reg descriptor-reg) eax-offset) (:arg start (any-reg descriptor-reg) ebx-offset) (:arg count (any-reg descriptor-reg) ecx-offset) (:temp uwp unsigned-reg esi-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst or block block) ; check for NULL pointer (inst jmp :z error)) (load-symbol-value uwp lisp::*current-unwind-protect-block*) ;; Does *cuwpb* match value stored in argument cuwp slot? (inst cmp uwp (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) ;; If a match, return to context in arg block. (inst jmp :e do-exit) ;; Not a match - return to *current-unwind-protect-block* context. ;; Important! Must save (and return) the arg 'block' for later use!! (move edx-tn block) (move block uwp) ;; Set next unwind protect context. (loadw uwp uwp unwind-block-current-uwp-slot) (store-symbol-value uwp lisp::*current-unwind-protect-block*) DO-EXIT (loadw ebp-tn block unwind-block-current-cont-slot) ;; Uwp-entry expects some things in known locations so that they can ;; be saved on the stack: the block in edx-tn; start in ebx-tn; and ;; count in ecx-tn (inst jmp (make-ea :byte :base block :disp (* unwind-block-entry-pc-slot word-bytes)))) #+assembler (define-assembly-routine (closure-tramp (:return-style :none)) () (loadw eax-tn eax-tn fdefn-function-slot other-pointer-type) (inst jmp (make-ea :dword :base eax-tn :disp (- (* closure-function-slot word-bytes) function-pointer-type)))) #+assembler (define-assembly-routine (undefined-tramp (:return-style :none)) () (let ((error (generate-error-code nil undefined-symbol-error (make-random-tn :kind :normal :sc (sc-or-lose 'descriptor-reg c::*backend*) :offset 0)))) (inst jmp error) (inst ret))) cmucl-21a/src/assembly/x86/bit-bash.lisp000066400000000000000000000000601260377556400201720ustar00rootroot00000000000000;; Just a dummy file to keep loadbackend happy. cmucl-21a/src/assembly/x86/support.lisp000066400000000000000000000026341260377556400202260ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/assembly/x86/support.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the machine specific support routines needed by ;;; the file assembler. ;;; ;;; Written by William Lott. ;;; (in-package :x86) (def-vm-support-routine generate-call-sequence (name style vop) (ecase style (:raw (values `((inst call (make-fixup ',name :assembly-routine))) nil)) (:full-call (values `((note-this-location ,vop :call-site) (inst call (make-fixup ',name :assembly-routine)) (note-this-location ,vop :single-value-return) (move esp-tn ebx-tn)) '((:save-p :compute-only)))) (:none (values `((inst jmp (make-fixup ',name :assembly-routine))) nil)))) (def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `(inst ret)) (:full-call `( (inst pop eax-tn) (inst add eax-tn 2) (inst jmp eax-tn))) (:none))) cmucl-21a/src/benchmarks/000077500000000000000000000000001260377556400154655ustar00rootroot00000000000000cmucl-21a/src/benchmarks/cascor1.lisp000066400000000000000000001544031260377556400177200ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: User -*- ;;; *************************************************************************** ;;; Common Lisp implementation of Cascade-Correlation learning algorithm. ;;; This version for export. Non-portable user-interface stuff excised. ;;; ;;; Written by: Scott E. Fahlman ;;; School of Computer Science ;;; Carnegie-Mellon University ;;; Pittsburgh, PA 15217 ;;; ;;; Phone: (412) 268-2575 ;;; Internet: fahlman@cs.cmu.edu ;;; ;;; This code has been placed in the public domain by the author. As a ;;; matter of simple courtesy, anyone using or adapting this code is ;;; expected to acknowledge the source. The author would like to hear ;;; about any attempts to use this system, successful or not. ;;; ;;; For an explanation of this algorithm and some results, see "The ;;; Cascade-Correlation Learning Architecture" by Scott E. Fahlman and ;;; Christian Lebiere in D. S. Touretzky (ed.), "Advances in Neural ;;; Information Processing Systems 2", Morgan Kaufmann, 1990. A somewhat ;;; longer version is available as CMU Computer Science Tech Report ;;; CMU-CS-90-100. ;;; ;;; *************************************************************************** ;;; EDIT HISTORY SINCE FIRST RELEASE: ;;; ;;; 8/24/90: ;;; Modified TEST-EPOCH so that it wouldn't mess up error statistics being ;;; passed from the output-training to input-training phase. Thanks to ;;; Scott Crowder for spotting this. ;;; ;;; 6/1/90: ;;; Fixed bug in INSTALL-NEW-UNIT. New unit's initial weight was being ;;; computed using *CAND-COR* values of the successful candidate, which is ;;; already zero. Now uses *CAND-PREV-COR*. Thanks to Tim Howells for ;;; spotting this. ;;; ;;; Modify BUILD-NET to check that *MAX-UNITS* is large enough. A couple of ;;; people got mysterious failures the first time they used lots of inputs. ;;; ;;; Made a small change in QUICKPROP-UPDATE to prevent rare divide-by-zero ;;; errors when p = s = 0.0. Thanks to Tom Dietterich. ;;; ;;; Added CHANGED-TRAINING-SET, which should be called when the training set ;;; is changed but you don't want to reinitialize the net. This rebuilds ;;; the caches. ;;; ;;; 11/9/90: ;;; Added some additional type declarations for maximum speed under certain ;;; Common Lisp compilers. ;;; *************************************************************************** ;;; (in-package "USER") ;;; This proclamation buys a certain amount of overall speed at the expense ;;; of runtime checking. Comment it out when debugging new, bug-infested code. ;;; #+declare-unsafe (proclaim '(optimize (speed 3) (space 0) (safety 0))) ;;; Style note: Because some of these runs take a long time, this code is ;;; extensively hacked for good performance under a couple of Common Lisp ;;; systems, some of which have poor performance on multi-dimensional ;;; arrays and some of which have weak type-inference in the compiler. ;;; Elegance and clarity have in some cases been sacrificed for speed. ;;; In some problems, floating point underflow errors may occur as a result ;;; of weight-decay and other operations. Most Common Lisp implementations ;;; have an option to turn floating underflows into zero values without ;;; signalling an error. You should enable this facility if it is ;;; available. If not, you'll either have to write a condition handler for ;;; floating underflows or live with the occasional underflow error. ;;; In CMU Common Lisp, we use the following incantation: ;;; (setq extensions:*ignore-floating-point-underflow* t) ;;; Compensate for the clumsy Common Lisp declaration system and weak ;;; type-inference in some Common Lisp compilers. ;;; INCF-SF, *SF, etc. are like INCF, *, etc., but they declare their ;;; operands and results to be short-floats. The code gets unreadable ;;; quickly if you insert all these declarations by hand. (defmacro incf-sf (place &optional (increment 1.0)) `(the short-float (incf (the short-float ,place) (the short-float ,increment)))) (defmacro decf-sf (place &optional (increment 1.0)) `(the short-float (decf (the short-float ,place) (the short-float ,increment)))) (defmacro *sf (&rest args) `(the short-float (* ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) (defmacro +sf (&rest args) `(the short-float (+ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) (defmacro -sf (&rest args) `(the short-float (- ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) (defmacro /sf (&rest args) `(the short-float (/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) ;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a ;;; fixnum. This is for compilers with weak type inference. (defmacro dotimes1 (form1 &body body) `(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body)) ;;; Create vector-access forms similar to SVREF, but for vectors of ;;; element-type SHORT-FLOAT and FIXNUM. (eval-when (compile load eval) (defconstant fvector-type (array-element-type (make-array '(1) :element-type 'short-float))) (defconstant ivector-type (array-element-type (make-array '(1) :element-type 'fixnum)))) (defmacro fvref (a i) "Like SVREF, but with vectors of element-type SHORT-FLOAT." (if (eq fvector-type t) `(the short-float (svref ,a ,i)) `(the short-float (aref (the (simple-array ,fvector-type (*)) ,a) ,i)))) (defmacro ivref (a i) "Like SVREF, but with vectors of element-type FIXNUM." (if (eq ivector-type t) `(the fixnum (svref ,a ,i)) `(the fixnum (aref (the (simple-array ,ivector-type (*)) ,a) ,i)))) ;;;; Assorted Parameters and Controls. ;;; Thse parameters and switches control the quickprop learning algorithm ;;; used to train the output weights and candidate units. (defvar *unit-type* :sigmoid "The type of activation function used by the hidden units. Options currently implemented are :sigmoid, :asigmoid, and :gaussian. Sigmoid is symmetric in range -0.5 to +0.5, while Asigmoid is asymmetric, 0.0 to 1.0.") (defvar *output-type* :sigmoid "The activation function to use on the output units. Options currently implemented are :linear and :sigmoid.") (defvar *raw-error* nil "If T, candidate units will try to correlate with the raw difference between actual and desired outputs. Else, they use the difference modified by the derivative of the output unit activation function.") (defvar *sigmoid-prime-offset* 0.1 "This is added to the derivative of the sigmoid function to prevent the system from getting stuck at the points where sigmoid-prime goes to zero.") (proclaim '(short-float *sigmoid-prime-offset*)) (defvar *weight-range* 1.0 "Input weights in the network get inital random values between plus and minus *weight-range*. This parameter also controls the initial weights on direct input-to-output links.") (proclaim '(short-float *weight-range*)) (defvar *weight-multiplier* 1.0 "The output weights for cadidate units get an initial value that is the negative of the correlation times this factor.") (proclaim '(short-float *weight-multiplier*)) (defvar *output-mu* 2.0 "Mu parmater used for quickprop training of output weights. The step size is limited to mu times the previous step.") (proclaim '(short-float *output-mu*)) (defvar *output-shrink-factor* (/ *output-mu* (+ 1.0 *output-mu*)) "Derived from *output-mu*. Used in computing whether the proposed step is too large.") (proclaim '(short-float *output-shrink-factor*)) (defvar *output-epsilon* 0.35 "Controls the amount of linear gradient descent to use in updating output weights.") (proclaim '(short-float *output-epsilon*)) (defvar *output-decay* 0.0001 "This factor times the current weight is added to the slope at the start of each output-training epoch. Keeps weights from growing too big.") (proclaim '(short-float *output-decay*)) (defvar *output-patience* 8 "If we go for this many epochs with no significant change, it's time to stop tuning. If 0, go on forever.") (proclaim '(fixnum *output-patience*)) (defvar *output-change-threshold* 0.01 "The error must change by at least this fraction of its old value in order to count as a significant change.") (proclaim '(short-float *output-change-threshold*)) (defvar *input-mu* 2.0 "Mu parmater used for quickprop training of input weights. The step size is limited to mu times the previous step.") (proclaim '(short-float *input-mu*)) (defvar *input-shrink-factor* (/ *input-mu* (+ 1.0 *input-mu*)) "Derived from *input-mu*. Used in computing whether the proposed step is too large.") (proclaim '(short-float *input-shrink-factor*)) (defvar *input-epsilon* 1.0 "Controls the amount of linear gradient descent to use in updating unit input weights.") (proclaim '(short-float *input-epsilon*)) (defvar *input-decay* 0.0 "This factor times the current weight is added to the slope at the start of each output-training epoch. Keeps weights from growing too big.") (proclaim '(short-float *input-decay*)) (defvar *input-patience* 8 "If we go for this many epochs with no significant change, it's time to stop tuning. If 0, go on forever.") (proclaim '(fixnum *input-patience*)) (defvar *input-change-threshold* 0.03 "The correlation score for the best unit must change by at least this fraction of its old value in order to count as a significant change.") (proclaim '(short-float *input-change-threshold*)) ;;; Variables related to error and correlation. (defvar *score-threshold* 0.4 "An output is counted as correct for a given case if the difference between that output and the desired value is smaller in magnitude than this value.") (proclaim '(short-float *score-threshold*)) (defvar *error-bits* 0 "Count number of bits in epoch that are wrong by more than *SCORE-THRESHOLD*") (proclaim '(fixnum *error-bits*)) (defvar *true-error* 0.0 "The sum-squared error at the network outputs. This is the value the algorithm is ultimately trying to minimize.") (proclaim '(short-float *true-error*)) (defvar *sum-error* 0.0 "Accumulate the sum of the error values after output training phase.") (proclaim '(short-float *sum-error*)) (defvar *sum-sq-error* 0.0 "Accumulate the sum of the squared error values after output training phase.") (proclaim '(short-float *sum-sq-error*)) (defvar *avg-error* 0.0 "Holds the average of error values after output training phase.") (proclaim '(short-float *avg-error*)) (defvar *best-candidate-score* 0.0 "The best correlation score found among all candidate units being trained.") (proclaim '(short-float *best-candidate-score*)) (defvar *best-candidate* 0 "The index of the candidate unit whose correlation score is best at present.") (proclaim '(fixnum *best-candidate*)) ;;; These variables and switches control the simulation and display. (defvar *use-cache* t "If T, cache the forward-pass values instead of repeatedly computing them. This can save a *lot* of time if all the cached values fit into memory.") (defparameter *epoch* 0 "Count of the number of times the entire training set has been presented.") (proclaim '(fixnum *epoch*)) (defvar *test* nil "If T, run a test epoch every so often during output training.") (defvar *test-interval* 0 "Run a test epoch every *test-interval* output training cycles.") (proclaim '(fixnum *test-interval*)) (defvar *single-pass* nil "When on, pause after next forward/backward cycle.") (defvar *single-epoch* nil "When on, pause after next training epoch.") (defparameter *step* nil "Turned briefly to T in order to continue after a pause.") ;;; The sets of training inputs and outputs are stored in parallel vectors. ;;; Each element is a SIMPLE-VECTOR holding short-float values, one for ;;; each input or output. Note: this is a simple vector, not a specialized ;;; vector of element-type short-float. (defvar *training-inputs* (make-array 0) "Vector of input patterns for training the net.") (proclaim '(simple-vector *training-inputs*)) (defvar *training-outputs* (make-array 0) "Vector of output patterns for training the net.") (proclaim '(simple-vector *training-outputs*)) (defvar *goal* (make-array 0) "The goal vector for the current training or testing case.") (proclaim '(simple-vector *goal*)) (defvar *max-cases* 0 "Maximum number of training cases that can be accommdated by the current data structures.") (proclaim '(fixnum *max-cases*)) (defvar *ncases* 0 "Number of training cases currently in use. Assume a contiguous block beginning with *FIRST-CASE*.") (proclaim '(fixnum *ncases*)) (defvar *first-case* 0 "Address of the first training case in the currently active set. Usually zero, but may differ if we are training on different chunks of the training set at different times.") (proclaim '(fixnum *first-case*)) ;;; For some benchmarks there is a separate set of values used for testing ;;; the network's ability to generalize. These values are not used during ;;; training. (defvar *test-inputs* '#() "Vector of input patterns for testing the net.") (proclaim '(simple-vector *test-inputs*)) (defvar *test-outputs* '#() "Vector of output patterns for testing the net.") (proclaim '(simple-vector *test-outputs*)) ;;;; Fundamental data structures. ;;; Unit values and weights are short flonums. ;;; Instead of representing each unit by a structure, we represent the ;;; unit by a fixnum. This is used to index into various vectors that hold ;;; per-unit information, such as the activation value of each unit. ;;; So the information concerning a given unit is found in a slice of values ;;; across many vectors, all with the same unit-index. ;;; Per-connection information for each connection COMING INTO unit is ;;; stored in a vector of vectors. The outer vector is indexed by the unit ;;; number, and the inner vector is then indexed by connection number. ;;; This is a sleazy way of implementing a 2-D array, faster in most Lisp ;;; systems than multiplying to do the index arithmetic, and more efficient ;;; if the units are sparsely connected. ;;; Unit 0, the "bias unit" is always at a maximum-on value. Next come ;;; some input "units", then some hidden units. ;;; Output units have their own separate set of data structures and ;;; indices. The units and outputs together form the "active" network. ;;; There are also separate data structures and indices for the "candidate" ;;; units that have not yet been added to the network. (defvar *max-units* 30 "Maximum number of input values and hidden units in the network.") (proclaim '(fixnum *max-units*)) (defvar *ninputs* 0 "Number of inputs for this problem.") (proclaim '(fixnum *ninputs*)) (defvar *noutputs* 0 "Number of outputs for this problem.") (proclaim '(fixnum *noutputs*)) (defvar *nunits* 0 "Current number of active units in the network. This count includes all inputs to the network and the bias unit.") (proclaim '(fixnum *nunits*)) (defvar *ncandidates* 8 "Number of candidate units whose inputs will be trained at once.") (proclaim '(fixnum *ncandidates*)) ;;; The following vectors hold values related to hidden units in the active ;;; net and their input weights. The vectors are created by BUILD-NET, after ;;; the dimension variables have been set up. (defvar *values* nil "Vector holding the current activation value for each unit and input in the active net.") (defvar *values-cache* nil "Holds a distinct *VALUES* vector for each of the *MAX-CASES* training cases. Once we have computed the *VALUES* vector for each training case, we can use it repeatedly until the weights or training cases change.") (defvar *extra-values* nil "Extra values vector to use when not using the cache.") ;;; Note: the *NCONNECTIONS* and *CONNECTIONS* vectors could be eliminated ;;; if we wanted to commit to total connectivity for all units. ;;; For now, we want to allow for sparse or irregular connectivity. (defvar *nconnections* nil "Vector holding the number of incoming connections for each unit.") (defvar *connections* nil "Vector that holds a connection vector for each unit J. Each entry in the connection vector holds a unit index I, indicating that this connection is from I to J.") (defvar *weights* nil "Vector of vectors with structure parallel to the *connections* vector. Each entry gives the weight associated with an incoming connection.") ;;; The following vectors hold values for the outputs of the active ;;; network and the output-side weights. (defvar *outputs* nil "Vector holding the network output values.") (defvar *errors* nil "Vector holding the current error value for each output.") (defvar *errors-cache* nil "Holds a distinct *ERRORS* vector for each of the *MAX-CASES* training cases. Once we have computed the *ERRORS* vector for a given training case, we can use it repeatedly until the weights of the training cases change.") (defvar *extra-errors* nil "Extra errors vector to use when not using the cache.") (defvar *output-weights* nil "Vector of vectors. For each output, we have a vector of output weights coming from the unit indicated by the index.") (defvar *output-deltas* nil "Vector of vectors, parallel with output weights. Each entry is the amount by which the corresponding output weight was changed last time.") (defvar *output-slopes* nil "Vector of vectors, parallel with output weights. Each entry is the partial derivative of the total error with repsect to the corresponding weight.") (defvar *output-prev-slopes* nil "Vector of vectors, parallel with output weights. Each entry is the previous value of the corresponding *OUTPUT-SLOPES* entry.") (defvar *output-weights-record* nil "The vector of output weights is recorded here after each output-training phase and just prior to the addition of the next unit. This record allows us to reconstruct the network's performance at each of these points in time.") ;;; The following vectors have one entry for each candidate unit in the ;;; pool of trainees. (defvar *cand-sum-values* nil "For each candidate unit, the sum of its values over an entire training set.") (defvar *cand-cor* nil "A vector with one entry for each candidate unit. This entry is a vector that holds the correlation between this unit's value and the residual error at each of the outputs, computed over a whole epoch.") (defvar *cand-prev-cor* nil "Holds the *cand-cor* values computed in the previous candidate training epoch.") (defvar *cand-weights* nil "A vector with one entry for each candidate unit. This entry is a vector that holds the current input weights for that candidate unit.") (defvar *cand-deltas* nil "A vector with one entry for each candidate unit. This entry is a vector that holds the input weights deltas for that candidate unit.") (defvar *cand-slopes* nil "A vector with one entry for each candidate unit. This entry is a vector that holds the input weights slopes for that candidate unit.") (defvar *cand-prev-slopes* nil "A vector with one entry for each candidate unit. This entry is a vector that holds the previous values of the input weight slopes for that candidate unit.") ;;; At present, each candidate receives a connection from every input and ;;; pre-existing unit. Rather than cons up a new *connections* vector for ;;; each of these, we can just use this one for all of them. (defvar *all-connections* nil "A *CONNECTIONS* vector that can be used by any unit that connects to all lower-numbered units, in order.") ;;;; Network-building utilities. (defun build-net (ninputs noutputs) "Create the network data structures, given the number of input and output connections. Get *MAX-UNITS* and other dimesntions from variables." (declare (fixnum ninputs noutputs)) ;; Check to make sure *MAX-UNITS* is big enough. (unless (> *max-units* (+ ninputs 1)) (error "*MAX-UNITS* must be greater than number of inputs plus 1.")) ;; Fill in assorted variables and create top-level vectors. (setq *ninputs* ninputs *noutputs* noutputs *max-cases* (length *training-inputs*) *ncases* *max-cases* *first-case* 0 *nunits* (+ 1 *ninputs*) *values-cache* (make-array *max-cases* :initial-element nil) *extra-values* (make-array *max-units* :element-type 'short-float :initial-element 0.0) *values* *extra-values* *nconnections* (make-array *max-units* :element-type 'fixnum :initial-element 0) *connections* (make-array *max-units* :initial-element nil) *weights* (make-array *max-units* :initial-element nil) *outputs* (make-array *noutputs* :element-type 'short-float :initial-element 0.0) *errors-cache* (make-array *max-cases* :initial-element nil) *extra-errors* (make-array *noutputs* :element-type 'short-float :initial-element 0.0) *errors* *extra-errors* *output-weights* (make-array *noutputs* :initial-element nil) *output-weights-record* (make-array *max-units* :initial-element nil) *output-deltas* (make-array *noutputs* :initial-element nil) *output-slopes* (make-array *noutputs* :initial-element nil) *output-prev-slopes* (make-array *noutputs* :initial-element nil) *cand-sum-values* (make-array *ncandidates* :element-type 'short-float :initial-element 0.0) *cand-cor* (make-array *ncandidates* :initial-element nil) *cand-prev-cor* (make-array *ncandidates* :initial-element nil) *cand-weights* (make-array *ncandidates* :initial-element nil) *cand-deltas* (make-array *ncandidates* :initial-element nil) *cand-slopes* (make-array *ncandidates* :initial-element nil) *cand-prev-slopes* (make-array *ncandidates* :initial-element nil)) ;; Only create the caches if *USE-CACHE* is on -- may not always have room. (when *use-cache* (dotimes1 (i *max-cases*) (setf (svref *values-cache* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *errors-cache* i) (make-array *noutputs* :element-type 'short-float :initial-element 0.0)))) ;; For each output, create the vectors holding per-weight information. (dotimes1 (i *noutputs*) (setf (svref *output-weights* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *output-deltas* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *output-slopes* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *output-prev-slopes* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0))) ;; For each candidate unit, create the vectors holding the correlations, ;; incoming weights, and other stats. (dotimes1 (i *ncandidates*) (setf (svref *cand-cor* i) (make-array *noutputs* :element-type 'short-float :initial-element 0.0)) (setf (svref *cand-prev-cor* i) (make-array *noutputs* :element-type 'short-float :initial-element 0.0)) (setf (svref *cand-weights* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *cand-deltas* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *cand-slopes* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *cand-prev-slopes* i) (make-array *max-units* :element-type 'short-float :initial-element 0.0)))) (defun random-weight () "Select a random weight, uniformly distributed over the interval from minus to plus *weight-range*." (-sf (random (*sf 2.0 *weight-range*)) *weight-range*)) (defun init-net () "Set up the network for a learning problem. Clean up all the data structures that may have become corrupted. Initialize the output weights to random values controlled by *weight-range*." ;; Set up the *ALL-CONNECTIONS* vector. (setq *all-connections* (make-array *max-units* :element-type 'fixnum)) (dotimes1 (i *max-units*) (setf (ivref *all-connections* i) i)) ;; Initialize the active unit data structures. (dotimes1 (i *max-units*) (setf (fvref *extra-values* i) 0.0) (setf (ivref *nconnections* i) 0) (setf (svref *connections* i) nil) (setf (svref *weights* i) nil) (setf (svref *output-weights-record* i) nil)) ;; Initialize the per-output data structures. (dotimes1 (i *noutputs*) (setf (fvref *outputs* i) 0.0) (setf (fvref *extra-errors* i) 0.0) (let ((ow (svref *output-weights* i)) (od (svref *output-deltas* i)) (os (svref *output-slopes* i)) (op (svref *output-prev-slopes* i))) (dotimes1 (j *max-units*) (setf (fvref ow j) 0.0) (setf (fvref od j) 0.0) (setf (fvref os j) 0.0) (setf (fvref op j) 0.0)) ;; Set up initial random weights for the input-to-output connections. (dotimes1 (j (1+ *ninputs*)) (setf (fvref ow j) (random-weight))))) ;; Initialize the caches if they are in use. (when *use-cache* (dotimes1 (j *max-cases*) (let ((v (svref *values-cache* j)) (e (svref *errors-cache* j))) (dotimes1 (i *max-units*) (setf (fvref v i) 0.0)) (dotimes1 (i *noutputs*) (setf (fvref e i) 0.0))))) ;; Candidate units get initialized in a separate routine. (init-candidates) ;; Do some other assorted housekeeping. (setf (fvref *extra-values* 0) 1.0) (setq *epoch* 0) (setq *nunits* (+ 1 *ninputs*)) (setq *error-bits* 0) (setq *true-error* 0.0) (setq *sum-error* 0.0) (setq *sum-sq-error* 0.0) (setq *best-candidate-score* 0.0) (setq *best-candidate* 0)) (defun changed-training-set () "Call this instead of BUILD-NET and INIT-NET if you want to leave existing hidden units in place and start from here with new training examples. Assumes that the number of net inputs and outputs remains the same, but the number of cases may have changed. Rebuilds the caches." (setq *max-cases* (length *training-inputs*) *ncases* *max-cases* *first-case* 0 *values-cache* (make-array *max-cases* :initial-element nil) *errors-cache* (make-array *max-cases* :initial-element nil)) ;; Only create the caches if *USE-CACHE* is on -- may not always have room. (when *use-cache* (dotimes1 (i *max-cases*) (setf (svref *errors-cache* i) (make-array *noutputs* :element-type 'short-float :initial-element 0.0)) (setq *values* (make-array *max-units* :element-type 'short-float :initial-element 0.0)) (setf (svref *values-cache* i) *values*) (set-up-inputs (svref *training-inputs* i)) (do ((j (1+ *ninputs*) (1+ j))) ((= j *nunits*)) (declare (fixnum j)) (compute-unit-value j))))) ;;;; Utilities for learning. (proclaim '(inline activation activation-prime)) (defun activation (sum) "Given the sum of weighted inputs, compute the unit's activation value. Defined unit types are :sigmoid, :asigmoid, and :gaussian." (declare (short-float sum)) (ecase *unit-type* (:sigmoid ;; Symmetric sigmoid function in range -0.5 to +0.5. (cond ((< sum -15.0) -0.5) ((> sum 15.0) +0.5) (t (-sf (/sf (+sf 1.0 (exp (-sf sum)))) 0.5)))) (:asigmoid ;; Asymmetric sigmoid in range 0.0 to 1.0. (cond ((< sum -15.0) 0.0) ((> sum 15.0) 1.0) (t (/sf 1.0 (+sf 1.0 (exp (-sf sum))))))) (:gaussian ;; Gaussian activation function in range 0.0 to 1.0. (let ((x (*sf -0.5 sum sum))) (if (< x -75.0) 0.0 (exp x)))))) ;;; Note: do not use *SIGMOID-PRIME-OFFSET* here, as it confuses the ;;; correlation machinery. But do use it in output-prime, since it does no ;;; harm there and the output units often get stuck at extreme values. (defun activation-prime (value sum) "Given the unit's activation value and sum of weighted inputs, compute the derivative of the activation with respect to the sum. Defined unit types are :sigmoid, :asigmoid, and :gaussian." (declare (short-float value sum)) (ecase *unit-type* (:sigmoid (-sf 0.25 (*sf value value))) (:asigmoid (*sf value (-sf 1.0 value))) (:gaussian (*sf (-sf value) sum)))) (proclaim '(inline output-function output-prime)) (defun output-function (sum) "Compute the value of an output, given the weighted sum of incoming values. Defined output types are :sigmoid and :linear." (declare (short-float sum)) (ecase *output-type* (:sigmoid (cond ((< sum -15.0) -0.5) ((> sum 15.0) +0.5) (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5)))) (:linear sum))) (defun output-prime (output) "Compute the derivative of an output with respect to the weighted sum of incoming values. Defined output types are :sigmoid and :linear." (declare (short-float output)) (ecase *output-type* (:sigmoid (+sf *sigmoid-prime-offset* (-sf 0.25 (*sf output output)))) (:linear 1.0))) ;;; The basic routine for doing Quickprop-style update of weights. ;;; Distilled essence of a year's work... (proclaim '(inline quickprop-update)) (defun quickprop-update (i weights deltas slopes prevs epsilon decay mu shrink-factor) "Given vectors holding weights, deltas, slopes, and previous slopes, and an index i, update weight(i) and delta(i) appropriately. Move slope(i) to prev(i) and zero out slope(i). Add weight decay term to each slope before doing the update." (let* ((w (fvref weights i)) (d (fvref deltas i)) (s (+sf (fvref slopes i) (*sf decay w))) (p (fvref prevs i)) (next-step 0.0)) (declare (short-float w p s d next-step)) ;; The step must always be downhill. (cond ;; If last step was negative... ((minusp d) ;; First, add in linear term if current slope is still positive. (when (plusp s) (decf-sf next-step (*sf epsilon s))) (cond ;; If current slope is close to or larger than prev slope... ((>= s (*sf shrink-factor p)) ;; Take maximum size negative step. (incf-sf next-step (*sf mu d))) ;; Else, use quadratic estimate. (t (incf-sf next-step (*sf d (/sf s (-sf p s))))))) ;; If last step was positive... ((plusp d) ;; First, add in linear term if current slope is still negative. (when (minusp s) (decf-sf next-step (*sf epsilon s))) (cond ;; If current slope is close to or more neg than prev slope... ((<= s (*sf shrink-factor p)) ;; Take maximum size positive step. (incf-sf next-step (*sf mu d))) ;; Else, use quadratic estimate. (t (incf-sf next-step (*sf d (/sf s (-sf p s))))))) ;; Last step was zero, so use only linear term. (t (decf-sf next-step (*sf epsilon s)))) ;; Having computed the next step, update the data vectors. (setf (fvref deltas i) next-step) (setf (fvref weights i) (+sf w next-step)) (setf (fvref prevs i) s) (setf (fvref slopes i) 0.0) nil)) ;;;; Machinery for training output weights. (defun set-up-inputs (input) "Set up all the inputs from the INPUT vector as the first few entries in in the values vector." (declare (simple-vector input)) (setf (fvref *values* 0) 1.0) (dotimes1 (i *ninputs*) (setf (fvref *values* (1+ i)) (the short-float (svref input i))))) (defun output-forward-pass () "Assume the *VALUES* vector has been set up. Just compute the network's outputs." (dotimes1 (j *noutputs*) (let ((ow (svref *output-weights* j)) (sum 0.0)) (declare (short-float sum)) (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref *values* i) (fvref ow i)))) (setf (fvref *outputs* j) (output-function sum))))) (defun compute-unit-value (j) "Assume that *VALUES* vector has been set up for all units with index less than J. Compute and record the value for unit J." (declare (fixnum j)) (let* ((c (svref *connections* j)) (w (svref *weights* j)) (sum 0.0)) (declare (short-float sum)) (dotimes1 (i (ivref *nconnections* j)) (incf-sf sum (*sf (fvref *values* (ivref c i)) (fvref w i)))) (setf (fvref *values* j) (activation sum)) nil)) (defun full-forward-pass (input) "Set up the inputs from the INPUT vector, then propagate activation values forward through all hidden units and output units." (set-up-inputs input) ;; For each hidden unit J, compute the activation value. (do ((j (1+ *ninputs*) (1+ j))) ((= j *nunits*)) (declare (fixnum j)) (compute-unit-value j)) ;; Now compute outputs. (output-forward-pass)) ;;; Note: We fill the *ERRORS* vector and related statistics with either ;;; the raw error or the error after modification by output-prime, ;;; depending on the *RAW-ERROR* switch. This controls what form of error ;;; the candidate units try to correlate with. All experiments reported in ;;; TR CMU-CS-90-100 assume *RAW-ERROR* is NIL, but this might not always ;;; be the best choice. (defun compute-errors (goal output-slopes-p stats-p) "GOAL is a vector of desired values for the output units. Compute and record the output errors for the current training case. If OUTPUT-SLOPES-P is T, then use errors to compute slopes for output weights. If STATS-P is T, accumulate error statistics." (declare (simple-vector goal)) (dotimes1 (j *noutputs*) (let* ((out (fvref *outputs* j)) (dif (-sf out (svref goal j))) (err-prime (*sf dif (output-prime out))) (os (svref *output-slopes* j))) (declare (short-float dif err-prime)) (when stats-p (unless (< (abs dif) *score-threshold*) (incf *error-bits*)) (incf-sf *true-error* (*sf dif dif))) (cond (*raw-error* (setf (fvref *errors* j) dif) (incf-sf *sum-error* dif) (incf-sf *sum-sq-error* (*sf dif dif))) (t (setf (fvref *errors* j) err-prime) (incf-sf *sum-error* err-prime) (incf-sf *sum-sq-error* (*sf err-prime err-prime)))) (when output-slopes-p (dotimes1 (i *nunits*) (incf-sf (fvref os i) (*sf err-prime (fvref *values* i)))))))) ;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the ;;; quickprop update in a good range across many different-sized training ;;; sets, but it's something of a hack. Choosing good epsilon values ;;; still requires some trial and error. (defun update-output-weights () "Update the output weights, using the pre-computed slopes, prev-slopes, and delta values. Uses the quickprop update function." (let ((eps (/ *output-epsilon* *ncases*))) (dotimes1 (j *noutputs*) (let ((ow (svref *output-weights* j)) (od (svref *output-deltas* j)) (os (svref *output-slopes* j)) (op (svref *output-prev-slopes* j))) (dotimes1 (i *nunits*) (quickprop-update i ow od os op eps *output-decay* *output-mu* *output-shrink-factor*)))))) ;;;; Outer loops for training output weights. (defun train-outputs-epoch () "Perform forward propagation once for each set of weights in the training vectors, computing errors and slopes. Then update the output weights." ;; Zero error accumulators. (setq *error-bits* 0) (setq *true-error* 0.0) (setq *sum-error* 0.0) (setq *sum-sq-error* 0.0) ;; User may have changed mu between epochs, so fix shrink-factor. (setq *output-shrink-factor* (/sf *output-mu* (+sf 1.0 *output-mu*))) ;; Now run through the training examples. (do ((i *first-case* (1+ i))) ((= i (the fixnum (+ *first-case* *ncases*)))) (declare (fixnum i)) (setq *goal* (svref *training-outputs* i)) (cond (*use-cache* (setq *values* (svref *values-cache* i)) (setq *errors* (svref *errors-cache* i)) (output-forward-pass)) (t (setq *values* *extra-values*) (setq *errors* *extra-errors*) (full-forward-pass (svref *training-inputs* i)))) (compute-errors *goal* t t)) ;; Do not change weights or count epoch if this run was perfect. (unless (= 0 *error-bits*) (update-output-weights) (incf *epoch*))) (defun record-output-weights () "Store the output weights developed after each output-training phase in the *ouput-weights-record* vector." (let ((record (make-array *noutputs* :initial-element nil))) (dotimes1 (o *noutputs*) (let ((original (svref *output-weights* o)) (copy (make-array *nunits* :element-type 'short-float :initial-element 0.0))) (dotimes1 (u *nunits*) (setf (fvref copy u) (fvref original u))) (setf (svref record o) copy))) (setf (svref *output-weights-record* (1- *nunits*)) record))) (defun train-outputs (max-epochs) "Train the output weights. If we exhaust MAX-EPOCHS, stop with value :TIMEOUT. If there are zero error bits, stop with value :WIN. Else, keep going until the true error has not changed by a significant amount for *OUTPUT-PATIENCE* epochs. Then return :STAGNANT. If *OUTPUT-PATIENCE* is zero, we do not stop until victory or until MAX-EPOCHS is used up." (declare (fixnum max-epochs)) (let ((last-error 0.0) (quit-epoch (+ *epoch* *output-patience*)) (first-time t)) (declare (fixnum quit-epoch) (short-float last-error)) (dotimes1 (i max-epochs (progn (record-output-weights) :timeout)) ;; Maybe run a test epoch to see how we're doing. (when (and *test* (not (= 0 *test-interval*)) (= 0 (mod i *test-interval*))) (test-epoch)) (train-outputs-epoch) (cond ((zerop *error-bits*) (record-output-weights) (return :win)) ((zerop *output-patience*)) (first-time (setq first-time nil) (setq last-error *true-error*)) ((> (abs (- *true-error* last-error)) (* last-error *output-change-threshold*)) (setq last-error *true-error*) (setq quit-epoch (+ *epoch* *output-patience*))) ((>= *epoch* quit-epoch) (record-output-weights) (return :stagnant)))))) ;;;; Machinery for Training, Selecting, and Installing Candidate Units. (defun init-candidates () "Give new random weights to all of the candidate units. Zero the other candidate-unit statistics." (dotimes1 (i *ncandidates*) (setf (fvref *cand-sum-values* i) 0.0) (let ((cw (svref *cand-weights* i)) (cd (svref *cand-deltas* i)) (cs (svref *cand-slopes* i)) (cp (svref *cand-prev-slopes* i)) (cc (svref *cand-cor* i)) (cpc (svref *cand-prev-cor* i))) (dotimes1 (j *nunits*) (setf (fvref cw j) (random-weight)) (setf (fvref cd j) 0.0) (setf (fvref cs j) 0.0) (setf (fvref cp j) 0.0)) (dotimes1 (o *noutputs*) (setf (fvref cc o) 0.0) (setf (fvref cpc o) 0.0))))) (defun install-new-unit () "Add the candidate-unit with the best correlation score to the active network. Then reinitialize the candidate pool." (when (>= *nunits* *max-units*) (error "Cannot add any more units.")) ;; For now, assume total connectivity. (setf (ivref *nconnections* *nunits*) *nunits*) (setf (svref *connections* *nunits*) *all-connections*) ;; Copy the weight vector for the new unit. (let ((w (make-array *nunits* :element-type 'short-float)) (cw (svref *cand-weights* *best-candidate*))) (dotimes1 (i *nunits*) (setf (fvref w i) (fvref cw i))) (setf (svref *weights* *nunits*) w) ;; Tell user about the new unit. (format t " Add unit ~S: ~S~%" (+ 1 *nunits*) w)) ;; Fix up output weights for candidate unit. ;; Use minus the correlation times the *weight-multiplier* as an ;; initial guess. At least the sign should be right. (dotimes1 (o *noutputs*) (setf (fvref (svref *output-weights* o) *nunits*) (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o)) *weight-multiplier*))) ;; If using cache, run an epoch to compute this unit's values. (when *use-cache* (dotimes1 (i *max-cases*) (setq *values* (svref *values-cache* i)) (compute-unit-value *nunits*))) ;; Reinitialize candidate units with random weights. (incf *nunits*) (init-candidates)) ;;; Note: Ideally, after each adjustment of the candidate weights, we would ;;; run two epochs. The first would just determine the correlations ;;; between the candidate unit outputs and the residual error. Then, in a ;;; second pass, we would adjust each candidate's input weights so as to ;;; maximize the absolute value of the correlation. We need to know the ;;; sign of the correlation for each candidate-output pair so that we know ;;; which direction to tune the input weights. ;;; Since this ideal method doubles the number of epochs required for ;;; training candidates, we cheat slightly and use the correlation values ;;; computed BEFORE the most recent weight update. This combines the two ;;; epochs, saving us almost a factor of two. To bootstrap the process, we ;;; begin with a single epoch that computes only the correlation. ;;; Since we look only at the sign of the correlation and since that sign ;;; should change very infrequently, this probably is OK. But keep a ;;; lookout for pathological situations in which this might cause ;;; oscillation. ;;; This function is used only once at the start of each output-training ;;; phase to prime the pump. After that, each call to compute-slopes also ;;; computes the error-value products for the next epoch. (defun compute-correlations () "For the current training pattern, compute the value of each candidate unit and begin to compute the correlation between that unit's value and the error at each output. We have already done a forward-prop and computed the error values for active units." (dotimes1 (u *ncandidates*) (let ((sum 0.0) (v 0.0) (cw (svref *cand-weights* u)) (cc (svref *cand-cor* u))) (declare (short-float sum v)) ;; Determine activation value of each candidate unit. (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref cw i) (fvref *values* i)))) (setq v (activation sum)) (incf-sf (fvref *cand-sum-values* u) v) ;; Accumulate value of each unit times error at each output. (dotimes1 (o *noutputs*) (incf-sf (fvref cc o) (*sf v (fvref *errors* o))))))) ;;; Note: When we were computing true correlations between candidates and ;;; outputs, this is where the normalization factors went in. Currently we ;;; are just using covariances, as explained in the tech report. So we ;;; make only two adjustments here. First, we subtract out the product of ;;; the mean error and the mean candidate value to keep things from ;;; exploding when the error has a non-zero mean. Second, we effectively ;;; scale the error values by the sum-squared error over all training ;;; cases. This just keeps us from having to adjust *input-epsilon* ;;; repeatedly as the error is gradually reduced to a small fraction of its ;;; initial size. (defun adjust-correlations () "Normalize each accumulated correlation value, and stuff the normalized form into the *cand-prev-cor* data structure. Then zero *cand-cor* to prepare for the next round. Note the unit with the best total correlation score." (setq *best-candidate* 0) (setq *best-candidate-score* 0.0) (dotimes1 (u *ncandidates*) (let* ((cc (svref *cand-cor* u)) (cpc (svref *cand-prev-cor* u)) (offset (*sf (fvref *cand-sum-values* u) *avg-error*)) (cor 0.0) (score 0.0)) (declare (short-float offset cor score)) (dotimes1 (o *noutputs*) (setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*)) (setf (fvref cpc o) cor) (setf (fvref cc o) 0.0) (incf-sf score (abs cor))) ;; Keep track of the candidate with the best overall correlation. (when (> score *best-candidate-score*) (setq *best-candidate-score* score) (setq *best-candidate* u))))) ;;; This is the key function in the candidate training process. (defun compute-slopes () "Given the correlation values for each candidate-output pair, compute the derivative of the candidate's score with respect to each incoming weight." (dotimes1 (u *ncandidates*) (let* ((sum 0.0) (value 0.0) (actprime 0.0) (direction 0.0) (cw (svref *cand-weights* u)) (cs (svref *cand-slopes* u)) (cc (svref *cand-cor* u)) (cpc (svref *cand-prev-cor* u))) (declare (short-float sum value actprime direction)) ;; Forward pass through each candidate unit to compute activation-prime. (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref cw i) (fvref *values* i)))) (setq value (activation sum)) (setq actprime (activation-prime value sum)) ;; Now compute which way we want to adjust each unit's incoming ;; activation. (dotimes1 (o *noutputs*) (let ((error (fvref *errors* o))) (decf-sf direction (*sf (if (minusp (fvref cpc o)) -1.0 1.0) (*sf actprime (/sf (-sf error *avg-error*) *sum-sq-error*)))) ;; Also accumulate the error-value products for use next epoch. (incf-sf (fvref cc o) (*sf error value)))) ;; Given the direction we want to push the candidate, compute ;; which way we want to tweak each incoming weight. (dotimes1 (i *nunits*) (incf-sf (fvref cs i) (*sf direction (fvref *values* i))))))) ;;; Note: Scaling *INPUT-EPSILON* by the number of cases and number of ;;; inputs to each unit seems to keep the quickprop update in a good range, ;;; as the network goes from small to large, and across many ;;; different-sized training sets. Still, choosing a good epsilon value ;;; requires some trial and error. (defun update-input-weights () "Update the input weights, using the pre-computed slopes, prev-slopes, and delta values. Uses the quickprop update function." (let ((eps (/ *input-epsilon* (* *ncases* *nunits*)))) (dotimes1 (u *ncandidates*) (let ((cw (svref *cand-weights* u)) (cd (svref *cand-deltas* u)) (cs (svref *cand-slopes* u)) (cp (svref *cand-prev-slopes* u))) (dotimes1 (i *nunits*) (quickprop-update i cw cd cs cp eps *input-decay* *input-mu* *input-shrink-factor*)))))) ;;; Outer loop for training the candidate unit(s). (defun train-inputs-epoch () "For each training pattern, perform a forward pass. Tune the candidate units' weights to maximize the correlation score of each." (do ((i *first-case* (1+ i))) ((= i (the fixnum (+ *first-case* *ncases*)))) (declare (fixnum i)) (setq *goal* (svref *training-outputs* i)) ;; Compute values and errors, or recall cached values. (cond (*use-cache* (setq *values* (svref *values-cache* i)) (setq *errors* (svref *errors-cache* i))) (t (setq *values* *extra-values*) (setq *errors* *extra-errors*) (full-forward-pass (svref *training-inputs* i)) (compute-errors *goal* nil nil))) ;; Compute the slopes we will use to adjust candidate weights. (compute-slopes)) ;; User may have changed mu between epochs, so fix shrink-factor. (setq *input-shrink-factor* (/sf *input-mu* (+sf 1.0 *input-mu*))) ;; Now adjust the candidate unit input weights using quickprop. (update-input-weights) ;; Fix up the correlation values for the next epoch. (adjust-correlations) (incf *epoch*)) (defun correlations-epoch () "Do an epoch through all active training patterns just to compute the initial correlations. After this one pass, we will update the correlations as we train." (do ((i *first-case* (1+ i))) ((= i (the fixnum (+ *first-case* *ncases*)))) (declare (fixnum i)) (setq *goal* (svref *training-outputs* i)) (cond (*use-cache* (setq *values* (svref *values-cache* i)) (setq *errors* (svref *errors-cache* i))) (t (setq *values* *extra-values*) (setq *errors* *extra-errors*) (full-forward-pass (svref *training-inputs* i)) (compute-errors *goal* nil nil))) (compute-correlations)) (adjust-correlations) (incf *epoch*)) (defun train-inputs (max-epochs) "Train the input weights of all candidates. If we exhaust MAX-EPOCHS, stop with value :TIMEOUT. Else, keep going until the best candidate unit's score has changed by a significant amount, and then until it does not change significantly for PATIENCE epochs. Then return :STAGNANT. If PATIENCE is zero, we do not stop until victory or until MAX-EPOCHS is used up." (declare (fixnum max-epochs)) (setq *avg-error* (/ *sum-error* (* *ncases* *noutputs*))) (correlations-epoch) (let ((last-score 0.0) (quit max-epochs) (first-time t)) (declare (fixnum quit) (short-float last-score)) (dotimes1 (i max-epochs :timeout) (train-inputs-epoch) (cond ((zerop *input-patience*)) (first-time (setq first-time nil) (setq last-score *best-candidate-score*)) ((> (abs (-sf *best-candidate-score* last-score)) (* last-score *input-change-threshold*)) (setq last-score *best-candidate-score*) (setq quit (+ i *input-patience*))) ((>= i quit) (return :stagnant)))))) ;;;; Outer Loop. (defun list-parameters () "Print out the current training parameters in abbreviated form." (format t "SigOff ~,2F, WtRng ~,2F, WtMul ~,2F~%" *sigmoid-prime-offset* *weight-range* *weight-multiplier*) (format t "OMu ~,2F, OEps ~,2F, ODcy ~,4F, OPat ~D, OChange ~,3F~%" *output-mu* *output-epsilon* *output-decay* *output-patience* *output-change-threshold*) (format t "IMu ~,2F, IEps ~,2F, IDcy ~,4F, IPat ~D, IChange ~,3F~%" *input-mu* *input-epsilon* *input-decay* *input-patience* *input-change-threshold*) (format t "Utype ~S, Otype ~S, RawErr ~S, Pool ~D~%" *unit-type* *output-type* *raw-error* *ncandidates*)) (defun train (outlimit inlimit rounds &optional (restart nil)) "Train the output weights until stagnation or victory is reached. Then train the input weights to stagnation or victory. Then install the best candidate unit and repeat. OUTLIMIT and INLIMIT are upper limits on the number of cycles in each output and input phase. ROUNDS is an upper limit on the number of unit-installation cycles. If RESTART is non-nil, we are restarting training from the current point -- do not reinitialize the net." (declare (fixnum outlimit inlimit rounds)) (unless restart (init-net)) (list-parameters) (when *use-cache* (dotimes1 (i *max-cases*) (setq *values* (svref *values-cache* i)) (set-up-inputs (svref *training-inputs* i)))) (dotimes1 (r rounds :lose) (case (train-outputs outlimit) (:win (list-parameters) (format t "Victory at ~S epochs, ~S units, ~S hidden, Error ~S.~%" *epoch* *nunits* (- *nunits* *ninputs* 1) *true-error*) (return nil)) (:timeout (format t "Epoch ~D: Out Timeout ~D bits wrong, error ~S.~2%" *epoch* *error-bits* *true-error*)) (:stagnant (format t "Epoch ~D: Out Stagnant ~D bits wrong, error ~S.~2%" *epoch* *error-bits* *true-error*))) (when *test* (test-epoch)) (case (train-inputs inlimit) (:timeout (format t "Epoch ~D: In Timeout. Cor: ~D~%" *epoch* *best-candidate-score*)) (:stagnant (format t "Epoch ~D: In Stagnant. Cor: ~D~%" *epoch* *best-candidate-score*))) (install-new-unit))) (defun test-epoch (&optional (*score-threshold* 0.49999)) "Perform forward propagation once for each set of weights in the training and testing vectors. Reporting the performance. Do not change any weights. Do not use the caches." (let ((*use-cache* nil) (*values* *extra-values*) (*errors* *extra-errors*) (*error-bits* 0) (*true-error* 0.0) (*sum-error* 0.0) (*sum-sq-error* 0.0)) ;; Run all training patterns and count errors. (dotimes1 (i (length *training-inputs*)) (setq *goal* (svref *training-outputs* i)) (full-forward-pass (svref *training-inputs* i)) (compute-errors *goal* nil t)) (format t "Training: ~D of ~D wrong, error ~S." *error-bits* (length *training-inputs*) *true-error*) ;; Zero some accumulators again. (setq *error-bits* 0) (setq *true-error* 0.0) (setq *sum-error* 0.0) (setq *sum-sq-error* 0.0) ;; Now run all test patterns and report the results. (when *test-inputs* (dotimes1 (i (length *test-inputs*)) (setq *goal* (svref *test-outputs* i)) (full-forward-pass (svref *test-inputs* i)) (compute-errors *goal* nil t))) (format t " Test: ~D of ~D wrong, error ~S.~%" *error-bits* (length *test-inputs*) *true-error*))) (defun test-setup (nunits weights output-weights) "Set up a network for testing, given stored weights and output weights." (init-net) (setq *weights* weights) (setq *output-weights* output-weights) (setq *nunits* nunits) (do ((i (1+ *ninputs*) (1+ i))) ((= i *nunits*)) (declare (fixnum i)) (setf (ivref *nconnections* i) i) (setf (svref *connections* i) *all-connections*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Example Applications ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Zig-Zag problem. An easy one, useful for testing the code. (defun build-zig-zag (n) "Build N pairs of 1-D zig-zag." (declare (fixnum n)) (setq *ninputs* 1) (setq *noutputs* 1) (let ((ti (make-array (* 2 n))) (to (make-array (* 2 n)))) (dotimes1 (i n) (setf (svref ti (* i 2)) (vector (+ i 1.0))) (setf (svref to (* i 2)) (vector (if (evenp i) 0.5 -0.5))) (setf (svref ti (1+ (* i 2))) (vector (- (+ i 1.0)))) (setf (svref to (1+ (* i 2))) (vector (if (evenp i) -0.5 0.5)))) (setq *training-inputs* ti) (setq *training-outputs* to) (setq *test-inputs* ti) (setq *test-outputs* to)) (build-net 1 1) (init-net)) ;;; Call this with something like (BUILD-ZIG-ZAG 4), then call ;;; something like (train 100 100 25). ;;; Two spirals problem. (defun build-two-spirals (&optional (n 97)) "Build N point-pairs of the two-spiral problem, with standard default of 97 pairs." (declare (fixnum n)) (setq *ninputs* 2) (setq *noutputs* 1) (let ((ti (make-array (* 2 n))) (to (make-array (* 2 n)))) (dotimes1 (i n) (let* ((angle (/ (* i (coerce pi 'short-float)) 16.0)) (radius (/ (* 6.5 (- 104.0 i)) 104)) (x (* radius (sin angle))) (y (* radius (cos angle)))) (setf (svref ti (* i 2)) (vector x y)) (setf (svref to (* i 2)) (vector 0.5)) (setf (svref ti (1+ (* i 2))) (vector (- x) (- y))) (setf (svref to (1+ (* i 2))) (vector -0.5)))) ;; Put the inner part of the spiral first on the list. (setq ti (nreverse ti)) (setq to (nreverse to)) (setq *training-inputs* ti) (setq *training-outputs* to) (setq *test-inputs* ti) (setq *test-outputs* to)) (build-net 2 1) (init-net)) ;;; To run this, call (BUILD-TWO-SPIRALS), set various control parameters, ;;; and then call something like (TRAIN 100 100 25). ;;; For parameters, try these: ;;; SigOff 0.10, WtRng 1.00, WtMul 1.00 ;;; OMu 2.00, OEps 1.00, ODcy 0.0001, OPat 12, OChange 0.010 ;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030 ;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8 (defvar *save-random-state* (make-random-state)) (defun time-two-spirals () (setq *random-state* (make-random-state *save-random-state*)) (build-two-spirals) (time (train 100 100 25))) ;;; The End. cmucl-21a/src/benchmarks/gabriel/000077500000000000000000000000001260377556400170725ustar00rootroot00000000000000cmucl-21a/src/benchmarks/gabriel/bmarks.lisp000066400000000000000000001754461260377556400212630ustar00rootroot00000000000000;;;; -*- Mode: Lisp; Package: User -*- ;;;; ;;;; This file contains the common lisp version of the lisp performance ;;;; benchmarks from Stanford. These were translated and tested using ;;;; Symbolics Common Lisp on a Symbolics 3600. The benchmarks in this ;;;; file have not been "tuned" to any particular implementation. ;;;; ;;;; The benchmarks have been substantially cleaned up and made truly ;;;; Common Lisp at CMU by Rob Maclachlan and Skef Wholey. Timing ;;;; functions for each benchmark have been added. Declarations have ;;;; been added by David B. McDonald. Declarations should only affect ;;;; performance on general purpose hardware. Also, this reduces or ;;;; eliminates the error checking and may allow the system to be ;;;; corrupted if incorrect programs are run. ;;;; ;;;; Suggestions or problems to PW@SAIL. (in-package "USER") #+proclaim-unsafe (proclaim '(optimize (safety 0) (speed 3) (space 0))) (proclaim '(inline assoc member)) #-cmu (proclaim '(declaration start-block end-block)) (proclaim '(start-block boyer)) ;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. ;;; Fairly CONS intensive. (defvar unify-subst) (defvar temp-temp) (defun add-lemma (term) (cond ((and (not (atom term)) (eq (car term) (quote equal)) (not (atom (cadr term)))) (setf (get (car (cadr term)) (quote lemmas)) (cons term (get (car (cadr term)) (quote lemmas))))) (t (error "~%ADD-LEMMA did not like term: ~a" term)))) (defun add-lemma-lst (lst) (cond ((null lst) t) (t (add-lemma (car lst)) (add-lemma-lst (cdr lst))))) (defun apply-subst (alist term) (cond ((atom term) (cond ((setq temp-temp (assoc term alist :test #'eq)) (cdr temp-temp)) (t term))) (t (cons (car term) (apply-subst-lst alist (cdr term)))))) (defun apply-subst-lst (alist lst) (cond ((null lst) nil) (t (cons (apply-subst alist (car lst)) (apply-subst-lst alist (cdr lst)))))) (defun falsep (x lst) (or (equal x (quote (f))) (member x lst :test #'eq))) (defun one-way-unify (term1 term2) (progn (setq unify-subst nil) (one-way-unify1 term1 term2))) (defun one-way-unify1 (term1 term2) (cond ((atom term2) (cond ((setq temp-temp (assoc term2 unify-subst :test #'eq)) (equal term1 (cdr temp-temp))) (t (setq unify-subst (cons (cons term2 term1) unify-subst)) t))) ((atom term1) nil) ((eq (car term1) (car term2)) (one-way-unify1-lst (cdr term1) (cdr term2))) (t nil))) (defun one-way-unify1-lst (lst1 lst2) (cond ((null lst1) t) ((one-way-unify1 (car lst1) (car lst2)) (one-way-unify1-lst (cdr lst1) (cdr lst2))) (t nil))) (defun rewrite (term) (cond ((atom term) term) (t (rewrite-with-lemmas (cons (car term) (rewrite-args (cdr term))) (get (car term) (quote lemmas)))))) (defun rewrite-args (lst) (cond ((null lst) nil) (t (cons (rewrite (car lst)) (rewrite-args (cdr lst)))))) (defun rewrite-with-lemmas (term lst) (cond ((null lst) term) ((one-way-unify term (cadr (car lst))) (rewrite (apply-subst unify-subst (caddr (car lst))))) (t (rewrite-with-lemmas term (cdr lst))))) (defun setup-boyer () (add-lemma-lst (quote ((equal (compile form) (reverse (codegen (optimize form) (nil)))) (equal (eqp x y) (equal (fix x) (fix y))) (equal (greaterp x y) (lessp y x)) (equal (lesseqp x y) (not (lessp y x))) (equal (greatereqp x y) (not (lessp x y))) (equal (boolean x) (or (equal x (t)) (equal x (f)))) (equal (iff x y) (and (implies x y) (implies y x))) (equal (even1 x) (if (zerop x) (t) (odd (1- x)))) (equal (countps- l pred) (countps-loop l pred (zero))) (equal (fact- i) (fact-loop i 1)) (equal (reverse- x) (reverse-loop x (nil))) (equal (divides x y) (zerop (remainder y x))) (equal (assume-true var alist) (cons (cons var (t)) alist)) (equal (assume-false var alist) (cons (cons var (f)) alist)) (equal (tautology-checker x) (tautologyp (normalize x) (nil))) (equal (falsify x) (falsify1 (normalize x) (nil))) (equal (prime x) (and (not (zerop x)) (not (equal x (add1 (zero)))) (prime1 x (1- x)))) (equal (and p q) (if p (if q (t) (f)) (f))) (equal (or p q) (if p (t) (if q (t) (f)) (f))) (equal (not p) (if p (f) (t))) (equal (implies p q) (if p (if q (t) (f)) (t))) (equal (fix x) (if (numberp x) x (zero))) (equal (if (if a b c) d e) (if a (if b d e) (if c d e))) (equal (zerop x) (or (equal x (zero)) (not (numberp x)))) (equal (plus (plus x y) z) (plus x (plus y z))) (equal (equal (plus a b) (zero)) (and (zerop a) (zerop b))) (equal (difference x x) (zero)) (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c))) (equal (equal (zero) (difference x y)) (not (lessp y x))) (equal (equal x (difference x y)) (and (numberp x) (or (equal x (zero)) (zerop y)))) (equal (meaning (plus-tree (append x y)) a) (plus (meaning (plus-tree x) a) (meaning (plus-tree y) a))) (equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a))) (equal (append (append x y) z) (append x (append y z))) (equal (reverse (append a b)) (append (reverse b) (reverse a))) (equal (times x (plus y z)) (plus (times x y) (times x z))) (equal (times (times x y) z) (times x (times y z))) (equal (equal (times x y) (zero)) (or (zerop x) (zerop y))) (equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn)) (equal (mc-flatten x y) (append (flatten x) y)) (equal (member x (append a b)) (or (member x a) (member x b))) (equal (member x (reverse y)) (member x y)) (equal (length (reverse x)) (length x)) (equal (member a (intersect b c)) (and (member a b) (member a c))) (equal (nth (zero) i) (zero)) (equal (exp i (plus j k)) (times (exp i j) (exp i k))) (equal (exp i (times j k)) (exp (exp i j) k)) (equal (reverse-loop x y) (append (reverse x) y)) (equal (reverse-loop x (nil)) (reverse x)) (equal (count-list z (sort-lp x y)) (plus (count-list z x) (count-list z y))) (equal (equal (append a b) (append a c)) (equal b c)) (equal (plus (remainder x y) (times y (quotient x y))) (fix x)) (equal (power-eval (big-plus1 l i base) base) (plus (power-eval l base) i)) (equal (power-eval (big-plus x y i base) base) (plus i (plus (power-eval x base) (power-eval y base)))) (equal (remainder y 1) (zero)) (equal (lessp (remainder x y) y) (not (zerop y))) (equal (remainder x x) (zero)) (equal (lessp (quotient i j) i) (and (not (zerop i)) (or (zerop j) (not (equal j 1))))) (equal (lessp (remainder x y) x) (and (not (zerop y)) (not (zerop x)) (not (lessp x y)))) (equal (power-eval (power-rep i base) base) (fix i)) (equal (power-eval (big-plus (power-rep i base) (power-rep j base) (zero) base) base) (plus i j)) (equal (gcd x y) (gcd y x)) (equal (nth (append a b) i) (append (nth a i) (nth b (difference i (length a))))) (equal (difference (plus x y) x) (fix y)) (equal (difference (plus y x) x) (fix y)) (equal (difference (plus x y) (plus x z)) (difference y z)) (equal (times x (difference c w)) (difference (times c x) (times w x))) (equal (remainder (times x z) z) (zero)) (equal (difference (plus b (plus a c)) a) (plus b c)) (equal (difference (add1 (plus y z)) z) (add1 y)) (equal (lessp (plus x y) (plus x z)) (lessp y z)) (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y))) (equal (lessp y (plus x y)) (not (zerop x))) (equal (gcd (times x z) (times y z)) (times z (gcd x y))) (equal (value (normalize x) a) (value x a)) (equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y))) (equal (listp (gopher x)) (listp x)) (equal (samefringe x y) (equal (flatten x) (flatten y))) (equal (equal (greatest-factor x y) (zero)) (and (or (zerop y) (equal y 1)) (equal x (zero)))) (equal (equal (greatest-factor x y) 1) (equal x 1)) (equal (numberp (greatest-factor x y)) (not (and (or (zerop y) (equal y 1)) (not (numberp x))))) (equal (times-list (append x y)) (times (times-list x) (times-list y))) (equal (prime-list (append x y)) (and (prime-list x) (prime-list y))) (equal (equal z (times w z)) (and (numberp z) (or (equal z (zero)) (equal w 1)))) (equal (greatereqpr x y) (not (lessp x y))) (equal (equal x (times x y)) (or (equal x (zero)) (and (numberp x) (equal y 1)))) (equal (remainder (times y x) y) (zero)) (equal (equal (times a b) 1) (and (not (equal a (zero))) (not (equal b (zero))) (numberp a) (numberp b) (equal (1- a) (zero)) (equal (1- b) (zero)))) (equal (lessp (length (delete x l)) (length l)) (member x l)) (equal (sort2 (delete x l)) (delete x (sort2 l))) (equal (dsort x) (sort2 x)) (equal (length (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7))))))) (plus 6 (length x7))) (equal (difference (add1 (add1 x)) 2) (fix x)) (equal (quotient (plus x (plus x y)) 2) (plus x (quotient y 2))) (equal (sigma (zero) i) (quotient (times i (add1 i)) 2)) (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x))) (equal (equal (difference x y) (difference z y)) (if (lessp x y) (not (lessp y z)) (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z))))) (equal (meaning (plus-tree (delete x y)) a) (if (member x y) (difference (meaning (plus-tree y) a) (meaning x a)) (meaning (plus-tree y) a))) (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x))) (equal (nth (nil) i) (if (zerop i) (nil) (zero))) (equal (last (append a b)) (if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b))) (equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z))) (equal (assignment x (append a b)) (if (assignedp x a) (assignment x a) (assignment x b))) (equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero))) (equal (flatten (cdr (gopher x))) (if (listp x) (cdr (flatten x)) (cons (zero) (nil)))) (equal (quotient (times y x) y) (if (zerop y) (zero) (fix x))) (equal (get j (set i val mem)) (if (eqp j i) val (get j mem))))))) (defun tautologyp (x true-lst false-lst) (cond ((truep x true-lst) t) ((falsep x false-lst) nil) ((atom x) nil) ((eq (car x) (quote if)) (cond ((truep (cadr x) true-lst) (tautologyp (caddr x) true-lst false-lst)) ((falsep (cadr x) false-lst) (tautologyp (cadddr x) true-lst false-lst)) (t (and (tautologyp (caddr x) (cons (cadr x) true-lst) false-lst) (tautologyp (cadddr x) true-lst (cons (cadr x) false-lst)))))) (t nil))) (defun tautp (x) (tautologyp (rewrite x) nil nil)) (defun boyer () (prog (ans term) (setq term (apply-subst (quote ((x f (plus (plus a b) (plus c (zero)))) (y f (times (times a b) (plus c d))) (z f (reverse (append (append a b) (nil)))) (u equal (plus a b) (difference x y)) (w lessp (remainder a b) (member a (length b))))) (quote (implies (and (implies x y) (and (implies y z) (and (implies z u) (implies u w)))) (implies x w))))) (setq ans (tautp term)))) (defun trans-of-implies (n) (list (quote implies) (trans-of-implies1 n) (list (quote implies) 0 n))) (defun trans-of-implies1 (n) (declare (fixnum n)) (cond ((eql n 1) (list (quote implies) 0 1)) (t (list (quote and) (list (quote implies) (1- n) n) (trans-of-implies1 (1- n)))))) (defun truep (x lst) (or (equal x (quote (t))) (member x lst :test #'eq))) (eval-when (load eval) (setup-boyer)) (defun time-boyer () (time (boyer))) (proclaim '(start-block browse)) ;;; BROWSE -- Benchmark to create and browse through an AI-like data base of units. ;;; n is # of symbols ;;; m is maximum amount of stuff on the plist ;;; npats is the number of basic patterns on the unit ;;; ipats is the instantiated copies of the patterns (defvar browse-rand 21.) (defmacro char1 (x) `(aref (string ,x) 0)) (defun init-browse (n m npats ipats) (declare (fixnum n m npats)) (let ((ipats (copy-tree ipats))) (do ((p ipats (cdr p))) ((null (cdr p)) (rplacd p ipats))) (do ((n n (1- n)) (i m (cond ((= (the fixnum i) 0) m) (t (1- i)))) (name (gentemp) (gentemp)) (a ())) ((= (the fixnum n) 0) a) (declare (fixnum n i m)) (push name a) (do ((i i (1- i))) ((= (the fixnum i) 0)) (declare (fixnum i)) (setf (get name (gensym)) nil)) (setf (get name 'pattern) (do ((i npats (1- i)) (ipats ipats (cdr ipats)) (a ())) ((= (the fixnum i) 0) a) (declare (fixnum i)) (push (car ipats) a))) (do ((j (- m i) (1- j))) ((= (the fixnum j) 0)) (declare (fixnum j)) (setf (get name (gensym)) nil))))) (defun browse-random () (setq browse-rand (mod (the fixnum (* (the fixnum browse-rand) 17.)) 251.))) (defun randomize (l) (do ((a ())) ((null l) a) (let ((n (mod (browse-random) (length l)))) (declare (fixnum n)) (cond ((= (the fixnum n) 0) (push (car l) a) (setq l (cdr l))) (t (do ((n n (1- n)) (x l (cdr x))) ((= n 1) (push (cadr x) a) (rplacd x (cddr x))) (declare (fixnum n)))))))) (defun match (pat dat alist) (cond ((null pat) (null dat)) ((null dat) ()) ((or (eq (car pat) '?) (eq (car pat) (car dat))) (match (cdr pat) (cdr dat) alist)) ((eq (car pat) '*) (or (match (cdr pat) dat alist) (match (cdr pat) (cdr dat) alist) (match pat (cdr dat) alist))) (t (cond ((atom (car pat)) (cond ((eq (char1 (car pat)) #\?) (let ((val (assoc (car pat) alist))) (cond (val (match (cons (cdr val) (cdr pat)) dat alist)) (t (match (cdr pat) (cdr dat) (cons (cons (car pat) (car dat)) alist)))))) ((eq (char1 (car pat)) #\*) (let ((val (assoc (car pat) alist))) (cond (val (match (append (cdr val) (cdr pat)) dat alist)) (t (do ((l () (nconc l (cons (car d) nil))) (e (cons () dat) (cdr e)) (d dat (cdr d))) ((null e) ()) (cond ((match (cdr pat) d (cons (cons (car pat) l) alist)) (return t)))))))))) (t (and (not (atom (car dat))) (match (car pat) (car dat) alist) (match (cdr pat) (cdr dat) alist))))))) (defun browse () (investigate (randomize (init-browse 100. 10. 4. '((a a a b b b b a a a a a b b a a a) (a a b b b b a a (a a)(b b)) (a a a b (b a) b a b a)))) '((*a ?b *b ?b a *a a *b *a) (*a *b *b *a (*a) (*b)) (? ? * (b a) * ? ?)))) (defun investigate (units pats) (do ((units units (cdr units))) ((null units)) (do ((pats pats (cdr pats))) ((null pats)) (do ((p (get (car units) 'pattern) (cdr p))) ((null p)) (match (car pats) (car p) ()))))) (defun time-browse () (time (browse))) (proclaim '(start-block ctak)) ;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. (defun ctak (x y z) (declare (fixnum x y z)) (catch 'ctak (ctak-aux x y z))) (defun ctak-aux (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) (throw 'ctak z)) (t (ctak-aux (catch 'ctak (ctak-aux (the fixnum (1- x)) y z)) (catch 'ctak (ctak-aux (the fixnum (1- y)) z x)) (catch 'ctak (ctak-aux (the fixnum (1- z)) x y)))))) (defun time-ctak () (format t "Note: 10 iterations.~%") (time (dotimes (i 10) (ctak 18 12 6)))) (proclaim '(start-block dderiv-run)) ;;; DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written ;;; by Vaughn Pratt. ;;; This benchmark is a variant of the simple symbolic derivative program ;;; (DERIV). The main change is that it is `table-driven.' Instead of using a ;;; large COND that branches on the CAR of the expression, this program finds ;;; the code that will take the derivative on the property list of the atom in ;;; the CAR position. So, when the expression is (+ . ), the code ;;; stored under the atom '+ with indicator DERIV will take and ;;; return the derivative for '+. The way that MacLisp does this is with the ;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an ;;; atomic name in that it expects an argument list and the compiler compiles ;;; code, but the name of the function with that code is stored on the ;;; property list of FOO under the indicator BAR, in this case. You may have ;;; to do something like: ;;; :property keyword is not Common Lisp. (defun dderiv-aux (a) (list '/ (dderiv a) a)) (defun +-dderiv (a) (cons '+ (mapcar #'dderiv a))) (setf (get '+ 'dderiv) #'+-dderiv) (defun --dderiv (a) (cons '- (mapcar #'dderiv a))) (setf (get '- 'dderiv) #'--dderiv) (defun *-dderiv (a) (list '* (cons '* a) (cons '+ (mapcar #'dderiv-aux a)))) (setf (get '* 'dderiv) #'*-dderiv) (defun /-dderiv (a) (list '- (list '/ (dderiv (car a)) (cadr a)) (list '/ (car a) (list '* (cadr a) (cadr a) (dderiv (cadr a)))))) (setf (get '/ 'dderiv) #'/-dderiv) (defun dderiv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) (t (let ((dderiv (get (car a) 'dderiv))) (cond (dderiv (funcall (the function dderiv) (cdr a))) (t 'error)))))) (defun dderiv-run () (do ((i 0 (1+ i))) ((= i 1000.)) (declare (fixnum i)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun time-dderiv () (time (dderiv-run))) (proclaim '(start-block deriv-run)) ;;; DERIV -- This is the Common Lisp version of a symbolic derivative benchmark ;;; written by Vaughn Pratt. It uses a simple subset of Lisp and does a lot of ;;; CONSing. (defun deriv-aux (a) (list '/ (deriv a) a)) (defun deriv (a) (cond ((atom a) (cond ((eq a 'x) 1) (t 0))) ((eq (car a) '+) (cons '+ (mapcar #'deriv (cdr a)))) ((eq (car a) '-) (cons '- (mapcar #'deriv (cdr a)))) ((eq (car a) '*) (list '* a (cons '+ (mapcar #'deriv-aux (cdr a))))) ((eq (car a) '/) (list '- (list '/ (deriv (cadr a)) (caddr a)) (list '/ (cadr a) (list '* (caddr a) (caddr a) (deriv (caddr a)))))) (t 'error))) (defun deriv-run () #| (declare (fixnum i)) ;improves the code a little Why, pray tell? |# (do ((i 0 (1+ i))) ((= i 1000.)) ;runs it 5000 times (declare (fixnum i)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) (defun time-deriv () (time (deriv-run))) (proclaim '(start-block destructive)) ;;; DESTRU -- Destructive operation benchmark (defun destructive (n m) (declare (fixnum n m)) (let ((l (do ((i 10. (the fixnum (1- i))) (a () (push () a))) ((= (the fixnum i) 0) a) (declare (fixnum i))))) (do ((i n (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (fixnum i)) (cond ((null (car l)) (do ((l l (cdr l))) ((null l)) (or (car l) (rplaca l (cons () ()))) (nconc (car l) (do ((j m (the fixnum (1- j))) (a () (push () a))) ((= (the fixnum j) 0) a) (declare (fixnum j)))))) (t (do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2))) ((null l2)) (rplacd (do ((j (floor (length (car l2)) 2) (the fixnum (1- j))) (a (car l2) (cdr a))) ((zerop (the fixnum j)) a) (declare (fixnum j)) (rplaca a i)) (let ((n (floor (length (car l1)) 2))) (cond ((= (the fixnum n) 0) (rplaca l1 ()) (car l1)) (t (do ((j n (the fixnum (1- j))) (a (car l1) (cdr a))) ((= j 1) (prog1 (cdr a) (rplacd a ()))) (declare (fixnum j)) (rplaca a i)))))))))))) (defun time-destructive () (time (destructive 600 50))) (proclaim '(start-block div2-test-1 div2-test-2)) ;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. ;;; This file contains a recursive as well as an iterative test. (defun create-n (n) (declare (fixnum n)) (do ((n n (1- n)) (a () (push () a))) ((= (the fixnum n) 0) a) (declare (fixnum n)))) (defvar div2-l (create-n 200.)) (defun iterative-div2 (l) (do ((l l (cddr l)) (a () (push (car l) a))) ((null l) a))) (defun recursive-div2 (l) (cond ((null l) ()) (t (cons (car l) (recursive-div2 (cddr l)))))) (defun div2-test-1 (l) (do ((i 300. (1- i))) ((= (the fixnum i) 0)) (declare (fixnum i)) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l) (iterative-div2 l))) (defun div2-test-2 (l) (do ((i 300. (1- i))) ((= (the fixnum i) 0)) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l) (recursive-div2 l))) (defun time-iterative-div2 () (time (div2-test-1 div2-l))) (defun time-recursive-div2 () (time (div2-test-2 div2-l))) (proclaim '(start-block fft)) ;;; FFT -- This is an FFT benchmark written by Harry Barrow. It tests a ;;; variety of floating point operations, including array references. (defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0)) (defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0)) ;areal = real part ;aimag = imaginary part (defun fft (areal aimag) (declare (type (simple-array single-float (1025)) areal aimag)) (prog ((ar areal) (ai aimag) (i 0) (j 0) (k 0) (m 0) (n 0) (le 0) (le1 0) (ip 0) (nv2 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (fixnum i j k m n le le1 ip nv2) (single-float ur ui wr wi tr ti)) (setq n (array-dimension ar 0) n (1- n) nv2 (floor n 2) m 0 ;compute m = log(n) i 1) l1 (cond ((< i n) (setq m (1+ m) i (+ i i)) (go l1))) (cond ((not (equal n (expt 2 m))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (- j k) k (/ k 2)) (go l6))) (setq j (+ j k) i (1+ i)) (cond ((< i n) (go l3))) (do ((l 1 (1+ l))) ((> l m)) ;loop thru stages (declare (fixnum l)) (setq le (expt 2 l) le1 (floor le 2) ur 1.0 ui 0.0 wr (cos (/ 3.14159265 (float le1))) wi (sin (/ 3.14159265 (float le1)))) (do ((j 1 (1+ j))) ((> j le1)) ;loop thru butterflies (declare (fixnum j)) (do ((i j (+ i le))) ((> i n)) ;do a butterfly (declare (fixnum i)) (setq ip (+ i le1) tr (- (* (aref ar ip) ur) (* (aref ai ip) ui)) ti (+ (* (aref ar ip) ui) (* (aref ai ip) ur))) (setf (aref ar ip) (- (aref ar i) tr)) (setf (aref ai ip) (- (aref ai i) ti)) (setf (aref ar i) (+ (aref ar i) tr)) (setf (aref ai i) (+ (aref ai i) ti)))) (setq tr (- (* ur wr) (* ui wi)) ti (+ (* ur wi) (* ui wr)) ur tr ui ti)) (return t))) (defmacro fft-bench () '(do ((ntimes 0 (1+ ntimes))) ((= ntimes 10.)) (declare (fixnum ntimes)) (fft re im))) (defun time-fft () (time (fft-bench))) (proclaim '(end-block)) ;;; FPRINT -- Benchmark to print to a file. (defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 wxyzab23 xyzabc34 123456ab 234567bc 345678cd 456789de 567890ef 678901fg 789012gh 890123hi)) (defun fprint-init-aux (m n atoms) (declare (fixnum m n)) (cond ((= (the fixnum m) 0) (pop atoms)) (t (do ((i n (- i 2)) (a ())) ((< i 1) a) (declare (fixnum i)) (push (pop atoms) a) (push (fprint-init-aux (1- m) n atoms) a))))) (defun fprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (fprint-init-aux m n atoms))) (defvar test-pattern (fprint-init 6. 6. test-atoms)) (defun fprint () (let ((stream (open "fprint.tst" :direction :output :if-exists :supersede))) (print test-pattern stream) (close stream))) (defun time-fprint () (time (fprint))) ;;; FREAD -- Benchmark to read from a file. ;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created ;;; by FPRINT. (defun fread () (let ((stream (open "fprint.tst" :direction :input))) (read stream) (close stream))) (defun time-fread () (time (fread))) (proclaim '(start-block pexptsq)) ;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic. ;;; Originally writen in Franz Lisp by Richard Fateman. ;;; PDIFFER1 appears in the code, but is not defined; is not called for in this ;;; test, however. (defvar *frpoly-v*) (defvar *x*) (defvar *alpha*) (defvar *a*) (defvar *b*) (defvar *chk) (defvar *l) (defvar *p) (defvar q*) (defvar u*) (defvar *var) (defvar *y*) (defvar frpoly-r) (defvar frpoly-r2) (defvar frpoly-r3) (defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order))) (defmacro pcoefp (e) `(atom ,e)) (defmacro pzerop (x) `(if (numberp ,x) ; no signp in CL (zerop ,x))) (defmacro pzero () 0) (defmacro cplus (x y) `(+ ,x ,y)) (defmacro ctimes (x y) `(* ,x ,y)) (defun pcoefadd (e c x) (if (pzerop c) x (cons e (cons c x)))) (defun pcplus (c p) (if (pcoefp p) (cplus p c) (psimp (car p) (pcplus1 c (cdr p))))) (defun pcplus1 (c x) (cond ((null x) (if (pzerop c) nil (cons 0 (cons c nil)))) ((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil)) (t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x))))))) (defun pctimes (c p) (if (pcoefp p) (ctimes c p) (psimp (car p) (pctimes1 c (cdr p))))) (defun pctimes1 (c x) (if (null x) nil (pcoefadd (car x) (ptimes c (cadr x)) (pctimes1 c (cddr x))))) (defun pplus (x y) (cond ((pcoefp x) (pcplus x y)) ((pcoefp y) (pcplus y x)) ((eq (car x) (car y)) (psimp (car x) (pplus1 (cdr y) (cdr x)))) ((pointergp (car x) (car y)) (psimp (car x) (pcplus1 y (cdr x)))) (t (psimp (car y) (pcplus1 x (cdr y)))))) (defun pplus1 (x y) (cond ((null x) y) ((null y) x) ((= (car x) (car y)) (pcoefadd (car x) (pplus (cadr x) (cadr y)) (pplus1 (cddr x) (cddr y)))) ((> (car x) (car y)) (cons (car x) (cons (cadr x) (pplus1 (cddr x) y)))) (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y))))))) (defun psimp (var x) (cond ((null x) 0) ((atom x) x) ((zerop (car x)) (cadr x)) (t (cons var x)))) (defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero)) ((pcoefp x) (pctimes x y)) ((pcoefp y) (pctimes y x)) ((eq (car x) (car y)) (psimp (car x) (ptimes1 (cdr x) (cdr y)))) ((pointergp (car x) (car y)) (psimp (car x) (pctimes1 y (cdr x)))) (t (psimp (car y) (pctimes1 x (cdr y)))))) (defun ptimes1 (*x* y) (prog (u* *frpoly-v*) (setq *frpoly-v* (setq u* (ptimes2 y))) a (setq *x* (cddr *x*)) (if (null *x*) (return u*)) (ptimes3 y) (go a))) (defun ptimes2 (y) (if (null y) nil (pcoefadd (+ (car *x*) (car y)) (ptimes (cadr *x*) (cadr y)) (ptimes2 (cddr y))))) (defun ptimes3 (y) (prog (e u c) a1 (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*) )) (cond ((pzerop c) (setq y (cddr y)) (go a1)) ((or (null *frpoly-v*) (> e (car *frpoly-v*))) (setq u* (setq *frpoly-v* (pplus1 u* (list e c)))) (setq y (cddr y)) (go a1)) ((= e (car *frpoly-v*)) (setq c (pplus c (cadr *frpoly-v*))) (if (pzerop c) ; never true, evidently (setq u* (setq *frpoly-v* (pdiffer1 u* (list (car *frpoly-v*) (cadr *frpoly-v*))))) (rplaca (cdr *frpoly-v*) c)) (setq y (cddr y)) (go a1))) a (cond ((and (cddr *frpoly-v*) (> (caddr *frpoly-v*) e)) (setq *frpoly-v* (cddr *frpoly-v*)) (go a))) (setq u (cdr *frpoly-v*)) b (if (or (null (cdr u)) (< (cadr u) e)) (rplacd u (cons e (cons c (cdr u)))) (go e)) (cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d)) (t (rplaca (cddr u) c))) e (setq u (cddr u)) d (setq y (cddr y)) (if (null y) (return nil)) (setq e (+ (car *x*) (car y)) c (ptimes (cadr y) (cadr *x*))) c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c))) (go b))) (defun pexptsq (p n) (do ((n (floor n 2) (floor n 2)) (s (if (oddp n) p 1))) ((zerop n) s) (setq p (ptimes p p)) (and (oddp n) (setq s (ptimes s p))))) (eval-when (load eval) (setf (get 'x 'order) 1) (setf (get 'y 'order) 2) (setf (get 'z 'order) 3) (defparameter frpoly-r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1) (defparameter frpoly-r2 (ptimes frpoly-r 100000)) ; r2 = 100000*r (defparameter frpoly-r3 (ptimes frpoly-r 1.0))) ; r3 = r with floating point coefficients (defun time-frpoly-fixnum () (time (dolist (exp '(2 5 10 15)) (pexptsq frpoly-r exp)))) (defun time-frpoly-bignum () (time (dolist (exp '(2 5 10 15)) (pexptsq frpoly-r2 exp)))) (defun time-frpoly-float () (time (dolist (exp '(2 5 10 15)) (pexptsq frpoly-r3 exp)))) (proclaim '(start-block puzzle)) ;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. (eval-when (compile load eval) (defconstant size 511) (defconstant classmax 3) (defconstant typemax 12) ); (defvar iii 0) (defvar kount 0) (defconstant dee 8) (proclaim '(type fixnum size classmax typemax iii kount dee)) (deftype class-vector () `(simple-vector ,(1+ classmax))) (deftype type-vector () `(simple-vector ,(1+ typemax))) (deftype size-vector () `(simple-vector ,(1+ size))) (deftype p-array () `(simple-array t (,(1+ typemax) ,(1+ size)))) (defvar piececount (make-array (1+ classmax) :initial-element 0)) (defvar class (make-array (1+ typemax) :initial-element 0)) (defvar piecemax (make-array (1+ typemax) :initial-element 0)) (defvar puzzle (make-array (1+ size))) (defvar puzzle-p (make-array (list (1+ typemax) (1+ size)))) (proclaim '(type type-vector class piecemax)) (proclaim '(type class-vector piececount)) (proclaim '(type size-vector puzzle)) (proclaim '(type p-array puzzle-p)) (defun fit (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (declare (fixnum end)) (do ((k 0 (1+ k))) ((> k end) t) (declare (fixnum k)) (cond ((aref puzzle-p i k) (cond ((svref puzzle (+ j k)) (return nil)))))))) (defun place (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (declare (fixnum end)) (do ((k 0 (1+ k))) ((> k end)) (declare (fixnum k)) (cond ((aref puzzle-p i k) (setf (svref puzzle (+ j k)) t)))) (setf (svref piececount (svref class i)) (the fixnum (- (the fixnum (svref piececount (svref class i))) 1))) (do ((k j (1+ k))) ((> k size) ; (terpri) ; (princ "Puzzle filled") 0) (declare (fixnum k)) (cond ((not (svref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (declare (fixnum end)) (do ((k 0 (1+ k))) ((> k end)) (declare (fixnum k)) (cond ((aref puzzle-p i k) (setf (svref puzzle (+ j k)) nil)))) (setf (svref piececount (svref class i)) (the fixnum (+ (the fixnum (svref piececount (svref class i))) 1))))) (defun trial (j) (declare (fixnum j)) (let ((k 0)) (declare (fixnum k)) (do ((i 0 (1+ i))) ((> i typemax) (setq kount (the fixnum (1+ (the fixnum kount)))) nil) (declare (fixnum i)) (cond ((not (eql (svref piececount (svref class i)) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) ; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1)) (setq kount (the fixnum (1+ (the fixnum kount)))) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (fixnum ii jj kk)) (let ((index 0)) (declare (fixnum index)) (do ((i 0 (1+ i))) ((> i ii)) (declare (fixnum i)) (do ((j 0 (1+ j))) ((> j jj)) (declare (fixnum j)) (do ((k 0 (1+ k))) ((> k kk)) (declare (fixnum k)) (setq index (+ i (the fixnum (* dee (the fixnum (+ j (the fixnum (* dee k)))))))) (setf (aref puzzle-p iii index) t)))) (setf (svref class iii) iclass) (setf (svref piecemax iii) index) (cond ((not (= iii typemax)) (setq iii (+ iii 1)))))) (defun puzzle () (do ((m 0 (1+ m))) ((> m size)) (declare (fixnum m)) (setf (svref puzzle m) t)) (do ((i 1 (1+ i))) ((> i 5)) (declare (fixnum i)) (do ((j 1 (1+ j))) ((> j 5)) (declare (fixnum j)) (do ((k 1 (1+ k))) ((> k 5)) (declare (fixnum k)) (setf (svref puzzle (+ i (the fixnum (* dee (the fixnum (+ j (the fixnum (* dee k)))))))) nil)))) (do ((i 0 (1+ i))) ((> i typemax)) (declare (fixnum i)) (do ((m 0 (1+ m))) ((> m size)) (declare (fixnum m)) (setf (aref puzzle-p i m) nil))) (setq iii 0) (definePiece 0 3 1 0) (definePiece 0 1 0 3) (definePiece 0 0 3 1) (definePiece 0 1 3 0) (definePiece 0 3 0 1) (definePiece 0 0 1 3) (definePiece 1 2 0 0) (definePiece 1 0 2 0) (definePiece 1 0 0 2) (definePiece 2 1 1 0) (definePiece 2 1 0 1) (definePiece 2 0 1 1) (definePiece 3 1 1 1) (setf (svref pieceCount 0) 13.) (setf (svref pieceCount 1) 3) (setf (svref pieceCount 2) 1) (setf (svref pieceCount 3) 1) (let ((m (+ 1 (the fixnum (* dee (the fixnum (+ 1 dee)))))) (n 0) (kount 0)) (declare (fixnum m n kount)) (cond ((fit 0 m) (setq n (place 0 m))) (t (format t "~%Error."))) (cond ((trial n) (format t "~%Success in ~4D trials." kount)) (t (format t "~%Failure."))))) (defun time-puzzle () (time (puzzle))) (proclaim '(start-block tak trtak)) ;;; TAK -- A vanilla version of the TAKeuchi function and one with tail recursion ;;; removed. (defun tak (x y z) (declare (fixnum x y z)) (if (not (< y x)) z (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y)))) (defun trtak (x y z) (declare (fixnum x y z)) (prog () tak (if (not (< y x)) (return z) (let ((a (tak (1- x) y z)) (b (tak (1- y) z x))) (setq z (tak (1- z) x y) x a y b) (go tak))))) (defun time-tak () (format t "Note: 10 iterations.~%") (time (dotimes (i 10) (tak 18 12 6)))) (defun time-rtak () (format t "Note: 10 iterations.~%") (time (dotimes (i 10) (trtak 18 12 6)))) (proclaim '(start-block mas)) ;;; TAKL -- The TAKeuchi function using lists as counters. (defun listn (n) (if (not (= 0 (the fixnum n))) (cons n (listn (1- n))))) (defvar l18 (listn 18.)) (defvar l12 (listn 12.)) (defvar l6 (listn 6.)) (defun mas (x y z) (declare (list x y z)) (if (not (shorterp y x)) z (mas (mas (cdr x) y z) (mas (cdr y) z x) (mas (cdr z) x y)))) (defun shorterp (x y) (declare (list x y)) (and y (or (null x) (shorterp (cdr x) (cdr y))))) (defun time-takl () (format t "Note: 10 iterations.~%") (time (dotimes (i 10) (mas l18 l12 l6)))) #| ;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache ;;; memory effects. Results should be the same as for TAK on stack machines. ;;; Distribution of calls is not completely flat. (defun tak0 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak1 (tak37 (the fixnum (1- x)) y z) (tak11 (the fixnum (1- y)) z x) (tak17 (the fixnum (1- z)) x y))))) (defun tak1 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak2 (tak74 (the fixnum (1- x)) y z) (tak22 (the fixnum (1- y)) z x) (tak34 (the fixnum (1- z)) x y))))) (defun tak2 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak3 (tak11 (the fixnum (1- x)) y z) (tak33 (the fixnum (1- y)) z x) (tak51 (the fixnum (1- z)) x y))))) (defun tak3 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak4 (tak48 (the fixnum (1- x)) y z) (tak44 (the fixnum (1- y)) z x) (tak68 (the fixnum (1- z)) x y))))) (defun tak4 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak5 (tak85 (the fixnum (1- x)) y z) (tak55 (the fixnum (1- y)) z x) (tak85 (the fixnum (1- z)) x y))))) (defun tak5 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak6 (tak22 (the fixnum (1- x)) y z) (tak66 (the fixnum (1- y)) z x) (tak2 (the fixnum (1- z)) x y))))) (defun tak6 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak7 (tak59 (the fixnum (1- x)) y z) (tak77 (the fixnum (1- y)) z x) (tak19 (the fixnum (1- z)) x y))))) (defun tak7 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak8 (tak96 (the fixnum (1- x)) y z) (tak88 (the fixnum (1- y)) z x) (tak36 (the fixnum (1- z)) x y))))) (defun tak8 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak9 (tak33 (the fixnum (1- x)) y z) (tak99 (the fixnum (1- y)) z x) (tak53 (the fixnum (1- z)) x y))))) (defun tak9 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak10 (tak70 (the fixnum (1- x)) y z) (tak10 (the fixnum (1- y)) z x) (tak70 (the fixnum (1- z)) x y))))) (defun tak10 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak11 (tak7 (the fixnum (1- x)) y z) (tak21 (the fixnum (1- y)) z x) (tak87 (the fixnum (1- z)) x y))))) (defun tak11 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak12 (tak44 (the fixnum (1- x)) y z) (tak32 (the fixnum (1- y)) z x) (tak4 (the fixnum (1- z)) x y))))) (defun tak12 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak13 (tak81 (the fixnum (1- x)) y z) (tak43 (the fixnum (1- y)) z x) (tak21 (the fixnum (1- z)) x y))))) (defun tak13 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak14 (tak18 (the fixnum (1- x)) y z) (tak54 (the fixnum (1- y)) z x) (tak38 (the fixnum (1- z)) x y))))) (defun tak14 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak15 (tak55 (the fixnum (1- x)) y z) (tak65 (the fixnum (1- y)) z x) (tak55 (the fixnum (1- z)) x y))))) (defun tak15 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak16 (tak92 (the fixnum (1- x)) y z) (tak76 (the fixnum (1- y)) z x) (tak72 (the fixnum (1- z)) x y))))) (defun tak16 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak17 (tak29 (the fixnum (1- x)) y z) (tak87 (the fixnum (1- y)) z x) (tak89 (the fixnum (1- z)) x y))))) (defun tak17 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak18 (tak66 (the fixnum (1- x)) y z) (tak98 (the fixnum (1- y)) z x) (tak6 (the fixnum (1- z)) x y))))) (defun tak18 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak19 (tak3 (the fixnum (1- x)) y z) (tak9 (the fixnum (1- y)) z x) (tak23 (the fixnum (1- z)) x y))))) (defun tak19 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak20 (tak40 (the fixnum (1- x)) y z) (tak20 (the fixnum (1- y)) z x) (tak40 (the fixnum (1- z)) x y))))) (defun tak20 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak21 (tak77 (the fixnum (1- x)) y z) (tak31 (the fixnum (1- y)) z x) (tak57 (the fixnum (1- z)) x y))))) (defun tak21 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak22 (tak14 (the fixnum (1- x)) y z) (tak42 (the fixnum (1- y)) z x) (tak74 (the fixnum (1- z)) x y))))) (defun tak22 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak23 (tak51 (the fixnum (1- x)) y z) (tak53 (the fixnum (1- y)) z x) (tak91 (the fixnum (1- z)) x y))))) (defun tak23 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak24 (tak88 (the fixnum (1- x)) y z) (tak64 (the fixnum (1- y)) z x) (tak8 (the fixnum (1- z)) x y))))) (defun tak24 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak25 (tak25 (the fixnum (1- x)) y z) (tak75 (the fixnum (1- y)) z x) (tak25 (the fixnum (1- z)) x y))))) (defun tak25 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak26 (tak62 (the fixnum (1- x)) y z) (tak86 (the fixnum (1- y)) z x) (tak42 (the fixnum (1- z)) x y))))) (defun tak26 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak27 (tak99 (the fixnum (1- x)) y z) (tak97 (the fixnum (1- y)) z x) (tak59 (the fixnum (1- z)) x y))))) (defun tak27 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak28 (tak36 (the fixnum (1- x)) y z) (tak8 (the fixnum (1- y)) z x) (tak76 (the fixnum (1- z)) x y))))) (defun tak28 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak29 (tak73 (the fixnum (1- x)) y z) (tak19 (the fixnum (1- y)) z x) (tak93 (the fixnum (1- z)) x y))))) (defun tak29 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak30 (tak10 (the fixnum (1- x)) y z) (tak30 (the fixnum (1- y)) z x) (tak10 (the fixnum (1- z)) x y))))) (defun tak30 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak31 (tak47 (the fixnum (1- x)) y z) (tak41 (the fixnum (1- y)) z x) (tak27 (the fixnum (1- z)) x y))))) (defun tak31 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak32 (tak84 (the fixnum (1- x)) y z) (tak52 (the fixnum (1- y)) z x) (tak44 (the fixnum (1- z)) x y))))) (defun tak32 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak33 (tak21 (the fixnum (1- x)) y z) (tak63 (the fixnum (1- y)) z x) (tak61 (the fixnum (1- z)) x y))))) (defun tak33 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak34 (tak58 (the fixnum (1- x)) y z) (tak74 (the fixnum (1- y)) z x) (tak78 (the fixnum (1- z)) x y))))) (defun tak34 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak35 (tak95 (the fixnum (1- x)) y z) (tak85 (the fixnum (1- y)) z x) (tak95 (the fixnum (1- z)) x y))))) (defun tak35 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak36 (tak32 (the fixnum (1- x)) y z) (tak96 (the fixnum (1- y)) z x) (tak12 (the fixnum (1- z)) x y))))) (defun tak36 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak37 (tak69 (the fixnum (1- x)) y z) (tak7 (the fixnum (1- y)) z x) (tak29 (the fixnum (1- z)) x y))))) (defun tak37 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak38 (tak6 (the fixnum (1- x)) y z) (tak18 (the fixnum (1- y)) z x) (tak46 (the fixnum (1- z)) x y))))) (defun tak38 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak39 (tak43 (the fixnum (1- x)) y z) (tak29 (the fixnum (1- y)) z x) (tak63 (the fixnum (1- z)) x y))))) (defun tak39 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak40 (tak80 (the fixnum (1- x)) y z) (tak40 (the fixnum (1- y)) z x) (tak80 (the fixnum (1- z)) x y))))) (defun tak40 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak41 (tak17 (the fixnum (1- x)) y z) (tak51 (the fixnum (1- y)) z x) (tak97 (the fixnum (1- z)) x y))))) (defun tak41 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak42 (tak54 (the fixnum (1- x)) y z) (tak62 (the fixnum (1- y)) z x) (tak14 (the fixnum (1- z)) x y))))) (defun tak42 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak43 (tak91 (the fixnum (1- x)) y z) (tak73 (the fixnum (1- y)) z x) (tak31 (the fixnum (1- z)) x y))))) (defun tak43 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak44 (tak28 (the fixnum (1- x)) y z) (tak84 (the fixnum (1- y)) z x) (tak48 (the fixnum (1- z)) x y))))) (defun tak44 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak45 (tak65 (the fixnum (1- x)) y z) (tak95 (the fixnum (1- y)) z x) (tak65 (the fixnum (1- z)) x y))))) (defun tak45 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak46 (tak2 (the fixnum (1- x)) y z) (tak6 (the fixnum (1- y)) z x) (tak82 (the fixnum (1- z)) x y))))) (defun tak46 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak47 (tak39 (the fixnum (1- x)) y z) (tak17 (the fixnum (1- y)) z x) (tak99 (the fixnum (1- z)) x y))))) (defun tak47 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak48 (tak76 (the fixnum (1- x)) y z) (tak28 (the fixnum (1- y)) z x) (tak16 (the fixnum (1- z)) x y))))) (defun tak48 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak49 (tak13 (the fixnum (1- x)) y z) (tak39 (the fixnum (1- y)) z x) (tak33 (the fixnum (1- z)) x y))))) (defun tak49 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak50 (tak50 (the fixnum (1- x)) y z) (tak50 (the fixnum (1- y)) z x) (tak50 (the fixnum (1- z)) x y))))) (defun tak50 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak51 (tak87 (the fixnum (1- x)) y z) (tak61 (the fixnum (1- y)) z x) (tak67 (the fixnum (1- z)) x y))))) (defun tak51 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak52 (tak24 (the fixnum (1- x)) y z) (tak72 (the fixnum (1- y)) z x) (tak84 (the fixnum (1- z)) x y))))) (defun tak52 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak53 (tak61 (the fixnum (1- x)) y z) (tak83 (the fixnum (1- y)) z x) (tak1 (the fixnum (1- z)) x y))))) (defun tak53 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak54 (tak98 (the fixnum (1- x)) y z) (tak94 (the fixnum (1- y)) z x) (tak18 (the fixnum (1- z)) x y))))) (defun tak54 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak55 (tak35 (the fixnum (1- x)) y z) (tak5 (the fixnum (1- y)) z x) (tak35 (the fixnum (1- z)) x y))))) (defun tak55 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak56 (tak72 (the fixnum (1- x)) y z) (tak16 (the fixnum (1- y)) z x) (tak52 (the fixnum (1- z)) x y))))) (defun tak56 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak57 (tak9 (the fixnum (1- x)) y z) (tak27 (the fixnum (1- y)) z x) (tak69 (the fixnum (1- z)) x y))))) (defun tak57 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak58 (tak46 (the fixnum (1- x)) y z) (tak38 (the fixnum (1- y)) z x) (tak86 (the fixnum (1- z)) x y))))) (defun tak58 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak59 (tak83 (the fixnum (1- x)) y z) (tak49 (the fixnum (1- y)) z x) (tak3 (the fixnum (1- z)) x y))))) (defun tak59 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak60 (tak20 (the fixnum (1- x)) y z) (tak60 (the fixnum (1- y)) z x) (tak20 (the fixnum (1- z)) x y))))) (defun tak60 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak61 (tak57 (the fixnum (1- x)) y z) (tak71 (the fixnum (1- y)) z x) (tak37 (the fixnum (1- z)) x y))))) (defun tak61 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak62 (tak94 (the fixnum (1- x)) y z) (tak82 (the fixnum (1- y)) z x) (tak54 (the fixnum (1- z)) x y))))) (defun tak62 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak63 (tak31 (the fixnum (1- x)) y z) (tak93 (the fixnum (1- y)) z x) (tak71 (the fixnum (1- z)) x y))))) (defun tak63 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak64 (tak68 (the fixnum (1- x)) y z) (tak4 (the fixnum (1- y)) z x) (tak88 (the fixnum (1- z)) x y))))) (defun tak64 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak65 (tak5 (the fixnum (1- x)) y z) (tak15 (the fixnum (1- y)) z x) (tak5 (the fixnum (1- z)) x y))))) (defun tak65 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak66 (tak42 (the fixnum (1- x)) y z) (tak26 (the fixnum (1- y)) z x) (tak22 (the fixnum (1- z)) x y))))) (defun tak66 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak67 (tak79 (the fixnum (1- x)) y z) (tak37 (the fixnum (1- y)) z x) (tak39 (the fixnum (1- z)) x y))))) (defun tak67 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak68 (tak16 (the fixnum (1- x)) y z) (tak48 (the fixnum (1- y)) z x) (tak56 (the fixnum (1- z)) x y))))) (defun tak68 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak69 (tak53 (the fixnum (1- x)) y z) (tak59 (the fixnum (1- y)) z x) (tak73 (the fixnum (1- z)) x y))))) (defun tak69 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak70 (tak90 (the fixnum (1- x)) y z) (tak70 (the fixnum (1- y)) z x) (tak90 (the fixnum (1- z)) x y))))) (defun tak70 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak71 (tak27 (the fixnum (1- x)) y z) (tak81 (the fixnum (1- y)) z x) (tak7 (the fixnum (1- z)) x y))))) (defun tak71 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak72 (tak64 (the fixnum (1- x)) y z) (tak92 (the fixnum (1- y)) z x) (tak24 (the fixnum (1- z)) x y))))) (defun tak72 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak73 (tak1 (the fixnum (1- x)) y z) (tak3 (the fixnum (1- y)) z x) (tak41 (the fixnum (1- z)) x y))))) (defun tak73 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak74 (tak38 (the fixnum (1- x)) y z) (tak14 (the fixnum (1- y)) z x) (tak58 (the fixnum (1- z)) x y))))) (defun tak74 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak75 (tak75 (the fixnum (1- x)) y z) (tak25 (the fixnum (1- y)) z x) (tak75 (the fixnum (1- z)) x y))))) (defun tak75 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak76 (tak12 (the fixnum (1- x)) y z) (tak36 (the fixnum (1- y)) z x) (tak92 (the fixnum (1- z)) x y))))) (defun tak76 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak77 (tak49 (the fixnum (1- x)) y z) (tak47 (the fixnum (1- y)) z x) (tak9 (the fixnum (1- z)) x y))))) (defun tak77 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak78 (tak86 (the fixnum (1- x)) y z) (tak58 (the fixnum (1- y)) z x) (tak26 (the fixnum (1- z)) x y))))) (defun tak78 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak79 (tak23 (the fixnum (1- x)) y z) (tak69 (the fixnum (1- y)) z x) (tak43 (the fixnum (1- z)) x y))))) (defun tak79 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak80 (tak60 (the fixnum (1- x)) y z) (tak80 (the fixnum (1- y)) z x) (tak60 (the fixnum (1- z)) x y))))) (defun tak80 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak81 (tak97 (the fixnum (1- x)) y z) (tak91 (the fixnum (1- y)) z x) (tak77 (the fixnum (1- z)) x y))))) (defun tak81 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak82 (tak34 (the fixnum (1- x)) y z) (tak2 (the fixnum (1- y)) z x) (tak94 (the fixnum (1- z)) x y))))) (defun tak82 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak83 (tak71 (the fixnum (1- x)) y z) (tak13 (the fixnum (1- y)) z x) (tak11 (the fixnum (1- z)) x y))))) (defun tak83 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak84 (tak8 (the fixnum (1- x)) y z) (tak24 (the fixnum (1- y)) z x) (tak28 (the fixnum (1- z)) x y))))) (defun tak84 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak85 (tak45 (the fixnum (1- x)) y z) (tak35 (the fixnum (1- y)) z x) (tak45 (the fixnum (1- z)) x y))))) (defun tak85 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak86 (tak82 (the fixnum (1- x)) y z) (tak46 (the fixnum (1- y)) z x) (tak62 (the fixnum (1- z)) x y))))) (defun tak86 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak87 (tak19 (the fixnum (1- x)) y z) (tak57 (the fixnum (1- y)) z x) (tak79 (the fixnum (1- z)) x y))))) (defun tak87 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak88 (tak56 (the fixnum (1- x)) y z) (tak68 (the fixnum (1- y)) z x) (tak96 (the fixnum (1- z)) x y))))) (defun tak88 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak89 (tak93 (the fixnum (1- x)) y z) (tak79 (the fixnum (1- y)) z x) (tak13 (the fixnum (1- z)) x y))))) (defun tak89 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak90 (tak30 (the fixnum (1- x)) y z) (tak90 (the fixnum (1- y)) z x) (tak30 (the fixnum (1- z)) x y))))) (defun tak90 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak91 (tak67 (the fixnum (1- x)) y z) (tak1 (the fixnum (1- y)) z x) (tak47 (the fixnum (1- z)) x y))))) (defun tak91 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak92 (tak4 (the fixnum (1- x)) y z) (tak12 (the fixnum (1- y)) z x) (tak64 (the fixnum (1- z)) x y))))) (defun tak92 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak93 (tak41 (the fixnum (1- x)) y z) (tak23 (the fixnum (1- y)) z x) (tak81 (the fixnum (1- z)) x y))))) (defun tak93 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak94 (tak78 (the fixnum (1- x)) y z) (tak34 (the fixnum (1- y)) z x) (tak98 (the fixnum (1- z)) x y))))) (defun tak94 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak95 (tak15 (the fixnum (1- x)) y z) (tak45 (the fixnum (1- y)) z x) (tak15 (the fixnum (1- z)) x y))))) (defun tak95 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak96 (tak52 (the fixnum (1- x)) y z) (tak56 (the fixnum (1- y)) z x) (tak32 (the fixnum (1- z)) x y))))) (defun tak96 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak97 (tak89 (the fixnum (1- x)) y z) (tak67 (the fixnum (1- y)) z x) (tak49 (the fixnum (1- z)) x y))))) (defun tak97 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak98 (tak26 (the fixnum (1- x)) y z) (tak78 (the fixnum (1- y)) z x) (tak66 (the fixnum (1- z)) x y))))) (defun tak98 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak99 (tak63 (the fixnum (1- x)) y z) (tak89 (the fixnum (1- y)) z x) (tak83 (the fixnum (1- z)) x y))))) (defun tak99 (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) z) (t (tak0 (tak0 (the fixnum (1- x)) y z) (tak0 (the fixnum (1- y)) z x) (tak0 (the fixnum (1- z)) x y))))) (defun time-takr () (time (tak0 18 12 6))) |# (proclaim '(start-block stak)) ;;; STAK -- The TAKeuchi function with special variables instead of parameter ;;; passing. (defvar stak-x) (defvar stak-y) (defvar stak-z) (defun stak (stak-x stak-y stak-z) (stak-aux)) (defun stak-aux () (if (not (< (the fixnum stak-y) (the fixnum stak-x))) stak-z (let ((stak-x (let ((stak-x (the fixnum (1- (the fixnum stak-x)))) (stak-y stak-y) (stak-z stak-z)) (stak-aux))) (stak-y (let ((stak-x (the fixnum (1- (the fixnum stak-y)))) (stak-y stak-z) (stak-z stak-x)) (stak-aux))) (stak-z (let ((stak-x (the fixnum (1- (the fixnum stak-z)))) (stak-y stak-x) (stak-z stak-y)) (stak-aux)))) (stak-aux)))) (defun time-stak () (format t "Note: 10 iterations.~%") (time (dotimes (i 10) (stak 18 12 6)))) (proclaim '(end-block)) ;;; TPRINT -- Benchmark to print and read to the terminal. (defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9 stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d 567d 678e 789f 890g)) (defun tprint-init (m n atoms) (let ((atoms (subst () () atoms))) (do ((a atoms (cdr a))) ((null (cdr a)) (rplacd a atoms))) (tprint-init-aux m n atoms))) (defun tprint-init-aux (m n atoms) (declare (fixnum m n)) (cond ((= (the fixnum m) 0) (pop atoms)) (t (do ((i n (- i 2)) (a ())) ((< i 1) a) (declare (fixnum i)) (push (pop atoms) a) (push (tprint-init-aux (1- m) n atoms) a))))) (defvar test-pattern (tprint-init 6. 6. test-atoms)) (defun time-tprint () (time (print test-pattern))) (proclaim '(start-block init-traverse run-traverse)) ;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. (defstruct node (parents ()) (sons ()) (sn (snb)) (entry1 ()) (entry2 ()) (entry3 ()) (entry4 ()) (entry5 ()) (entry6 ()) (mark ())) (defvar sn 0) (defvar rand 21.) (defvar count 0) (defvar marker nil) (defvar root) (proclaim '(fixnum sn rand count)) (defun snb () (setq sn (the fixnum (1+ (the fixnum sn))))) (defun seed () (setq rand 21.)) (defun traverse-random () (setq rand (rem (the fixnum (* (the fixnum rand) 17.)) 251.))) (defun traverse-remove (n q) (cond ((eq (cdr (car q)) (car q)) (prog2 () (caar q) (rplaca q ()))) ((= (the fixnum n) 0) (prog2 () (caar q) (do ((p (car q) (cdr p))) ((eq (cdr p) (car q)) (rplaca q (rplacd p (cdr (car q)))))))) (t (do ((n n (the fixnum (1- n))) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p))) ((= (the fixnum n) 0) (prog2 () (car q) (rplacd q p))) (declare (fixnum n)))))) (defun traverse-select (n q) (do ((n n (the fixnum (1- n))) (q (car q) (cdr q))) ((= (the fixnum n) 0) (car q)) (declare (fixnum n)))) (defun add (a q) (cond ((null q) `(,(let ((x `(,a))) (rplacd x x) x))) ((null (car q)) (let ((x `(,a))) (rplacd x x) (rplaca q x))) (t (rplaca q (rplacd (car q) `(,a .,(cdr (car q)))))))) (defun create-structure (n) (declare (fixnum n)) (let ((a `(,(make-node)))) (do ((m (the fixnum (1- n)) (the fixnum (1- m))) (p a)) ((= (the fixnum m) 0) (setq a `(,(rplacd p a))) (do ((unused a) (used (add (traverse-remove 0 a) ())) (x) (y)) ((null (car unused)) (find-root (traverse-select 0 used) n)) (setq x (traverse-remove (rem (traverse-random) n) unused)) (setq y (traverse-select (rem (traverse-random) n) used)) (add x used) (setf (node-sons y) `(,x .,(node-sons y))) (setf (node-parents x) `(,y .,(node-parents x))) )) (declare (fixnum m)) (push (make-node) a)))) (defun find-root (node n) (declare (fixnum n)) (do ((n n (the fixnum (1- n)))) ((= (the fixnum n) 0) node) (declare (fixnum n)) (cond ((null (node-parents node)) (return node)) (t (setq node (car (node-parents node))))))) (defun travers (node mark) (cond ((eq (node-mark node) mark) ()) (t (setf (node-mark node) mark) (setq count (the fixnum (1+ count))) (setf (node-entry1 node) (not (node-entry1 node))) (setf (node-entry2 node) (not (node-entry2 node))) (setf (node-entry3 node) (not (node-entry3 node))) (setf (node-entry4 node) (not (node-entry4 node))) (setf (node-entry5 node) (not (node-entry5 node))) (setf (node-entry6 node) (not (node-entry6 node))) (do ((sons (node-sons node) (cdr sons))) ((null sons) ()) (travers (car sons) mark))))) (defun traverse (root) (let ((count 0)) (travers root (setq marker (not marker))) count)) (defun init-traverse() (prog1 nil (setq root (create-structure 100.)))) (defun run-traverse () (do ((i 50. (the fixnum (1- i)))) ((= (the fixnum i) 0)) (declare (fixnum i)) (traverse root) (traverse root) (traverse root) (traverse root) (traverse root))) (defun time-init-traverse () (time (init-traverse))) (defun time-run-traverse () (time (run-traverse))) (proclaim '(start-block triangle)) ;;; TRIANG -- Board game benchmark. (defvar board (make-array 16. :initial-element 1)) (setf (aref board 5) 0) (defvar triang-sequence (make-array 14. :initial-element 0)) (defvar triang-a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6))) (defvar triang-b (make-array 37. :initial-contents '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5))) (defvar triang-c (make-array 37. :initial-contents '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4))) (defvar answer) (defvar final) (proclaim '(type simple-vector board triang-sequence triang-a triang-b triang-c)) (defun last-position () (do ((i 1 (1+ i))) ((= i 16.) 0) (declare (fixnum i)) (if (= 1 (the fixnum (aref board i))) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final) (push lp final))) (push (cdr (coerce (the simple-vector triang-sequence) 'list)) answer) t) ; this is a hack to replace LISTARRAY ((and (= 1 (the fixnum (aref board (aref triang-a i)))) (= 1 (the fixnum (aref board (aref triang-b i)))) (= 0 (the fixnum (aref board (aref triang-c i))))) (setf (aref board (aref triang-a i)) 0) (setf (aref board (aref triang-b i)) 0) (setf (aref board (aref triang-c i)) 1) (setf (aref triang-sequence depth) i) (do ((j 0 (1+ j)) (depth (1+ depth))) ((or (= j 36.) (try j depth)) ()) (declare (fixnum j depth))) (setf (aref board (aref triang-a i)) 1) (setf (aref board (aref triang-b i)) 1) (setf (aref board (aref triang-c i)) 0) ()))) (defun triangle (i) (let ((answer ()) (final ())) (try i 1))) (defun time-triangle () (time (triangle 22))) cmucl-21a/src/benchmarks/gabriel/ctak.lisp000066400000000000000000000010551260377556400207060ustar00rootroot00000000000000(in-package "USER") ;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility. (defun ctak (x y z) (declare (fixnum x y z)) (catch 'ctak (ctak-aux x y z))) (defun ctak-aux (x y z) (declare (fixnum x y z)) (cond ((not (< y x)) (throw 'ctak z)) (t (ctak-aux (catch 'ctak (ctak-aux (the fixnum (1- x)) y z)) (catch 'ctak (ctak-aux (the fixnum (1- y)) z x)) (catch 'ctak (ctak-aux (the fixnum (1- z)) x y)))))) (defun time-ctak () (time (ctak 18 12 6))) cmucl-21a/src/benchmarks/gabriel/fft.lisp000066400000000000000000000046621260377556400205520ustar00rootroot00000000000000(in-package "USER") (proclaim '(optimize (safety 0) (speed 3) (space 0))) ;;; FFT -- This is an FFT benchmark written by Harry Barrow. It tests a ;;; variety of floating point operations, including array references. (defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0)) (defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0)) ;areal = real part ;aimag = imaginary part (defun fft (areal aimag) (declare (type (simple-array single-float (1025)) areal aimag)) (prog ((ar areal) (ai aimag) (i 0) (j 0) (k 0) (m 0) (n 0) (le 0) (le1 0) (ip 0) (nv2 0) (ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0)) (declare (fixnum i j k m n le le1 ip nv2) (single-float ur ui wr wi tr ti)) (setq n (array-dimension ar 0) n (1- n) nv2 (floor n 2) m 0 ;compute m = log(n) i 1) l1 (cond ((< i n) (setq m (1+ m) i (+ i i)) (go l1))) (cond ((not (equal n (expt 2 m))) (princ "error ... array size not a power of two.") (read) (return (terpri)))) (setq j 1 ;interchange elements i 1) ;in bit-reversed order l3 (cond ((< i j) (setq tr (aref ar j) ti (aref ai j)) (setf (aref ar j) (aref ar i)) (setf (aref ai j) (aref ai i)) (setf (aref ar i) tr) (setf (aref ai i) ti))) (setq k nv2) l6 (cond ((< k j) (setq j (- j k) k (/ k 2)) (go l6))) (setq j (+ j k) i (1+ i)) (cond ((< i n) (go l3))) (do ((l 1 (1+ l))) ((> l m)) ;loop thru stages (declare (fixnum l)) (setq le (expt 2 l) le1 (floor le 2) ur 1.0 ui 0.0 wr (cos (/ 3.14159265 (float le1))) wi (sin (/ 3.14159265 (float le1)))) (do ((j 1 (1+ j))) ((> j le1)) ;loop thru butterflies (declare (fixnum j)) (do ((i j (+ i le))) ((> i n)) ;do a butterfly (declare (fixnum i)) (setq ip (+ i le1) tr (- (* (aref ar ip) ur) (* (aref ai ip) ui)) ti (+ (* (aref ar ip) ui) (* (aref ai ip) ur))) (setf (aref ar ip) (- (aref ar i) tr)) (setf (aref ai ip) (- (aref ai i) ti)) (setf (aref ar i) (+ (aref ar i) tr)) (setf (aref ai i) (+ (aref ai i) ti)))) (setq tr (- (* ur wr) (* ui wi)) ti (+ (* ur wi) (* ui wr)) ur tr ui ti)) (return t))) (defmacro fft-bench () '(do ((ntimes 0 (1+ ntimes))) ((= ntimes 10.)) (declare (fixnum ntimes)) (fft re im))) (defun time-fft () (time (fft-bench))) cmucl-21a/src/benchmarks/gabriel/puzzle.c000066400000000000000000000103051260377556400205660ustar00rootroot00000000000000# define size 511 # define classMax 3 # define typeMax 12 # define d 8 # define true 1 # define false 0 static int class[typeMax+1]; static int pieceCount[classMax+1]; static int pieceMax[typeMax+1]; static int puzzle[size+1]; static int p[typeMax+1][size+1]; static int kount,clock; fit(i,j) int i,j; { register k,plim; plim = pieceMax[i]; for (k=0; k <= plim; k++) { if (p[i][k]) { if (puzzle[j+k]) return (false); } } return(true); } int place (i,j) int i,j; { register k,plim; plim = pieceMax[i]; for (k = 0; k <= plim; k++) if (p[i][k]) puzzle[j+k] = true; pieceCount[class[i]] = pieceCount[class[i]] - 1; for (k=j; k <= size; k++) if (!puzzle[k]) { return(k); } printf("Puzzle filled.\n"); return(0); } remove(i,j) int i,j; { register k,plim; plim = pieceMax[i]; for (k=0; k<=plim; k++) if (p[i][k]) puzzle[j+k] = false; pieceCount[class[i]] = pieceCount[class[i]] + 1; } trial(j) int j; { register i,k; for (i = 0; i <= typeMax; i++) if (pieceCount[class[i]] != 0) if (fit (i, j)) { k = place (i, j); if (trial(k)||(k == 0)) { /* printf("piece %d at %d\n",i+1,k+1); */ kount = kount + 1; return(true); } else remove (i, j); } kount = kount + 1; return(false); } main() { register i,j,k,m,n; /* printf("starting\n"); */ for (m = 0; m<=size; m++) puzzle[m] = true; for (i=1; i <= 5; i++) for (j=1; j<=5; j++) for (k=1; k<=5 ; k++) puzzle[i+d*(j+d*k)] = false; for (i=0;i<=typeMax;i++) for (j=0;j<=size;j++) p[i][j] = false; for (i=0;i<=3;i++) for (j=0;j<=1;j++) for (k = 0;k<=0;k++) p[0][i+d*(j+d*k)] = true; class[0] = 0; pieceMax[0] = 3+d*1+d*d*0; for (i=0;i<=1;i++) for (j=0;j<=0;j++) for (k=0;k<=3;k++) p[1][i+d*(j+d*k)] = true; class[1] = 0; pieceMax[1] = 1+d*0+d*d*3; for (i=0;i<=0;i++) for (j=0;j<=3;j++) for (k=0;k<=1;k++) p[2][i+d*(j+d*k)] = true; class[2] = 0; pieceMax[2] = 0+d*3+d*d*1; for (i=0;i<=1;i++) for (j=0;j<=3;j++) for (k=0;k<=0;k++) p[3][i+d*(j+d*k)] = true; class[3] = 0; pieceMax[3] = 1+d*3+d*d*0; for (i=0;i<=3;i++) for (j=0;j<=0;j++) for (k=0;k<=1;k++) p[4][i+d*(j+d*k)] = true; class[4] = 0; pieceMax[4] = 3+d*0+d*d*1; for (i=0;i<=0;i++) for (j=0;j<=1;j++) for (k=0;k<=3;k++) p[5][i+d*(j+d*k)] = true; class[5] = 0; pieceMax[5] = 0+d*1+d*d*3; for (i=0;i<=2;i++) for (j=0;j<=0;j++) for (k=0;k<=0;k++) p[6][i+d*(j+d*k)] = true; class[6] = 1; pieceMax[6] = 2+d*0+d*d*0; for (i=0;i<=0;i++) for (j=0;j<=2;j++) for (k=0;k<=0;k++) p[7][i+d*(j+d*k)] = true; class[7] = 1; pieceMax[7] = 0+d*2+d*d*0; for (i=0;i<=0;i++) for (j=0;j<=0;j++) for (k=0;k<=2;k++) p[8][i+d*(j+d*k)] = true; class[8] = 1; pieceMax[8] = 0+d*0+d*d*2; for (i=0;i<=1;i++) for (j=0;j<=1;j++) for (k=0;k<=0;k++) p[9][i+d*(j+d*k)] = true; class[9] = 2; pieceMax[9] = 1+d*1+d*d*0; for (i=0;i<=1;i++) for (j=0;j<=0;j++) for (k=0;k<=1;k++) p[10][i+d*(j+d*k)] = true; class[10] = 2; pieceMax[10] = 1+d*0+d*d*1; for (i=0;i<=0;i++) for (j=0;j<=1;j++) for (k=0;k<=1;k++) p[11][i+d*(j+d*k)] = true; class[11] = 2; pieceMax[11] = 0+d*1+d*d*1; for (i=0;i<=1;i++) for (j=0;j<=1;j++) for (k=0;k<=1;k++) p[12][i+d*(j+d*k)] = true; class[12] = 3; pieceMax[12] = 1+d*1+d*d*1; pieceCount[0] = 13; pieceCount[1] = 3; pieceCount[2] = 1; pieceCount[3] = 1; m = 1+d*(1+d*1); kount = 0; if (fit(0, m)) { n = place(0, m) ; } else { printf("error 1\n"); } /* printf("n = %d n\n",n); */ if (trial(n)) { printf("success in %d trials\n", kount); } else { printf("failure\n"); } /* printf("elapsed user time:\n"); */ } cmucl-21a/src/benchmarks/gabriel/puzzle.lisp000066400000000000000000000077261260377556400213300ustar00rootroot00000000000000;;;; -*- Mode: Lisp; Package: User -*- ;;;; (in-package "USER") (proclaim '(optimize (safety 0) (speed 3))) ;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. (defconstant size 511) (defconstant classmax 3) (defconstant typemax 12) (defvar iii 0) (defvar kount 0) (defconstant dee 8) (proclaim '(type fixnum size classmax typemax iii kount dee)) (defvar piececount (make-array (1+ classmax) :initial-element 0)) (defvar class (make-array (1+ typemax) :initial-element 0)) (defvar piecemax (make-array (1+ typemax) :initial-element 0)) (defvar puzzle (make-array (1+ size))) (defvar p (make-array (list (1+ typemax) (1+ size)))) (proclaim '(type simple-vector piececount class piecemax puzzle)) (defun fit (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (do ((k 0 (1+ k))) ((> k end) t) (declare (fixnum k)) (cond ((aref p i k) (cond ((svref puzzle (+ j k)) (return nil)))))))) (defun place (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (do ((k 0 (1+ k))) ((> k end)) (declare (fixnum k)) (cond ((aref p i k) (setf (svref puzzle (+ j k)) t)))) (setf (svref piececount (svref class i)) (- (svref piececount (svref class i)) 1)) (do ((k j (1+ k))) ((> k size) ; (terpri) ; (princ "Puzzle filled") 0) (declare (fixnum k)) (cond ((not (svref puzzle k)) (return k)))))) (defun puzzle-remove (i j) (declare (fixnum i j)) (let ((end (svref piecemax i))) (do ((k 0 (1+ k))) ((> k end)) (declare (fixnum k)) (cond ((aref p i k) (setf (svref puzzle (+ j k)) nil)))) (setf (svref piececount (svref class i)) (+ (svref piececount (svref class i)) 1)))) (defun trial (j) (declare (fixnum j)) (let ((k 0)) (declare (fixnum k)) (do ((i 0 (1+ i))) ((> i typemax) (setq kount (1+ kount)) nil) (declare (fixnum i)) (cond ((not (= (svref piececount (svref class i)) 0)) (cond ((fit i j) (setq k (place i j)) (cond ((or (trial k) (= k 0)) ; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1)) (setq kount (+ kount 1)) (return t)) (t (puzzle-remove i j)))))))))) (defun definepiece (iclass ii jj kk) (declare (fixnum ii jj kk)) (let ((index 0)) (do ((i 0 (1+ i))) ((> i ii)) (declare (fixnum i)) (do ((j 0 (1+ j))) ((> j jj)) (declare (fixnum j)) (do ((k 0 (1+ k))) ((> k kk)) (declare (fixnum k)) (setq index (+ i (* dee (+ j (* dee k))))) (setf (aref p iii index) t)))) (setf (svref class iii) iclass) (setf (svref piecemax iii) index) (cond ((not (= iii typemax)) (setq iii (+ iii 1)))))) (defun puzzle () (do ((m 0 (1+ m))) ((> m size)) (declare (fixnum m)) (setf (svref puzzle m) t)) (do ((i 1 (1+ i))) ((> i 5)) (declare (fixnum i)) (do ((j 1 (1+ j))) ((> j 5)) (declare (fixnum j)) (do ((k 1 (1+ k))) ((> k 5)) (declare (fixnum k)) (setf (svref puzzle (+ i (* dee (+ j (* dee k))))) nil)))) (do ((i 0 (1+ i))) ((> i typemax)) (declare (fixnum i)) (do ((m 0 (1+ m))) ((> m size)) (declare (fixnum m)) (setf (aref p i m) nil))) (setq iii 0) (definePiece 0 3 1 0) (definePiece 0 1 0 3) (definePiece 0 0 3 1) (definePiece 0 1 3 0) (definePiece 0 3 0 1) (definePiece 0 0 1 3) (definePiece 1 2 0 0) (definePiece 1 0 2 0) (definePiece 1 0 0 2) (definePiece 2 1 1 0) (definePiece 2 1 0 1) (definePiece 2 0 1 1) (definePiece 3 1 1 1) (setf (svref pieceCount 0) 13.) (setf (svref pieceCount 1) 3) (setf (svref pieceCount 2) 1) (setf (svref pieceCount 3) 1) (let ((m (+ 1 (* dee (+ 1 dee)))) (n 0) (kount 0)) (declare (fixnum m n kount)) (cond ((fit 0 m) (setq n (place 0 m))) (t (write-string " Error."))) (cond ((trial n) (write-string " Success in ") (print kount) (write-string " trials.")) (t (write-string " Failure.") )))) (defun time-puzzle () (time (puzzle))) cmucl-21a/src/benchmarks/gabriel/tak.lisp000066400000000000000000000012361260377556400205440ustar00rootroot00000000000000;;; TAK -- A vanilla version of the TAKeuchi function. (in-package "USER") (proclaim '(optimize (speed 1) (safety 1) (brevity 0))) (defun tak (x y z) (declare (fixnum x y z)) (if (not (< y x)) z (tak (tak (the fixnum (1- x)) y z) (tak (the fixnum (1- y)) z x) (tak (the fixnum (1- z)) x y)))) (defun time-tak () (time (tak 18 12 6))) (proclaim '(optimize (speed 3) (safety 0))) (defun fast-tak (x y z) (declare (fixnum x y z)) (if (not (< y x)) z (fast-tak (fast-tak (the fixnum (1- x)) y z) (fast-tak (the fixnum (1- y)) z x) (fast-tak (the fixnum (1- z)) x y)))) (defun time-fast-tak () (time (fast-tak 18 12 6))) cmucl-21a/src/benchmarks/gabriel/triang.lisp000066400000000000000000000034151260377556400212520ustar00rootroot00000000000000 ;;; TRIANG -- Board game benchmark. (defvar board (make-array 16. :initial-element 1)) (setf (aref board 5) 0) (defvar sequence (make-array 14. :initial-element 0)) (defvar a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6))) (defvar b (make-array 37. :initial-contents '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5))) (defvar c (make-array 37. :initial-contents '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4))) (defvar answer) (defvar final) (proclaim '(type simple-vector board sequence a b c)) (defun last-position () (do ((i 1 (1+ i))) ((= i 16.) 0) (declare (fixnum i)) (if (= 1 (the fixnum (aref board i))) (return i)))) (defun try (i depth) (declare (fixnum i depth)) (cond ((= depth 14) (let ((lp (last-position))) (unless (member lp final) (push lp final))) (push (cdr (coerce (the simple-vector sequence) 'list)) answer) t) ; this is a hack to replace LISTARRAY ((and (= 1 (the fixnum (aref board (aref a i)))) (= 1 (the fixnum (aref board (aref b i)))) (= 0 (the fixnum (aref board (aref c i))))) (setf (aref board (aref a i)) 0) (setf (aref board (aref b i)) 0) (setf (aref board (aref c i)) 1) (setf (aref sequence depth) i) (do ((j 0 (1+ j)) (depth (1+ depth))) ((or (= j 36.) (try j depth)) ()) (declare (fixnum j depth))) (setf (aref board (aref a i)) 1) (setf (aref board (aref b i)) 1) (setf (aref board (aref c i)) 0) ()))) (defun triangle (i) (let ((answer ()) (final ())) (try i 1))) #| (defun time-triangle () (time (triangle 22))) |# cmucl-21a/src/benchmarks/oprofile.lisp000066400000000000000000000237051260377556400202040ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*- ;;; ;;; This code has been placed in the public domain by the author. ;;; It is distributed without warranty of any kind. ;;; ;;; Description: Simple profiling facility. ;;; ;;; Author: Skef Wholey, Rob MacLachlan ;;; ;;; Current maintainer: Rob MacLachlan ;;; ;;; Address: Carnegie-Mellon University ;;; Computer Science Department ;;; Pittsburgh, PA 15213 ;;; ;;; Net address: ram@cs.cmu.edu ;;; ;;; Copyright status: Public domain. ;;; ;;; Compatibility: Runs in any valid Common Lisp. Three small implementation- ;;; dependent changes can be made to improve performance and prettiness. ;;; ;;; Dependencies: The macro Quickly-Get-Time and the function ;;; Required-Arguments should probably be tailored to the implementation for ;;; the best results. They will default to working, albeit inefficent, forms ;;; in non-CMU implementations. The Total-Consing macro is used to profile ;;; consing: in unknown implementations 0 will be used. ;;; See the "Implementation Parameters" section. ;;; ;;; Note: a timing overhead factor is computed at load time. This will be ;;; incorrect if profiling code is run in a different environment than this ;;; file was loaded in. For example, saving a core image on a high ;;; performance machine and running it on a low performance one will result ;;; in use of an erroneously small timing overhead factor. ;;; (in-package "OPROFILE") (export '(*timed-functions* profile unprofile report-time reset-time)) (progn #-:cmu (eval-when (compile eval) (warn "You may want to supply an implementation-specific ~ Quickly-Get-Time function.")) (defconstant quick-time-units-per-second internal-time-units-per-second) (defmacro quickly-get-time () `(get-internal-run-time))) ;;; To avoid unnecessary consing in the "encapsulation" code, we find out the ;;; number of required arguments, and use &rest to capture only non-required ;;; arguments. The function Required-Arguments returns two values: the first ;;; is the number of required arguments, and the second is T iff there are any ;;; non-required arguments (e.g. &optional, &rest, &key). #+nil (defun required-arguments (name) (let ((function (symbol-function name))) (if (eql (system:%primitive get-type function) system:%function-type) (let ((min (ldb system:%function-min-args-byte (system:%primitive header-ref function system:%function-min-args-slot))) (max (ldb system:%function-max-args-byte (system:%primitive header-ref function system:%function-max-args-slot))) (rest (ldb system:%function-rest-arg-byte (system:%primitive header-ref function system:%function-rest-arg-slot))) (key (ldb system:%function-keyword-arg-byte (system:%primitive header-ref function system:%function-keyword-arg-slot)))) (values min (or (/= min max) (/= rest 0) (/= key 0)))) (values 0 t)))) #-:cmu (progn (eval-when (compile eval) (warn "You may want to add an implementation-specific Required-Arguments function.")) (eval-when (load eval) (defun required-arguments (name) (declare (ignore name)) (values 0 t)))) ;;; The Total-Consing macro is called to find the total number of bytes consed ;;; since the beginning of time. #+cmu (defmacro total-consing () '(ext:get-bytes-consed)) #-:cmu (progn (eval-when (compile eval) (warn "No consing will be reported unless a Total-Consing function is ~ defined.")) (defmacro total-consing () '0)) (defvar *timed-functions* () "List of functions that are currently being timed.") (defmacro profile (&rest names) "Wraps profiling code around the named functions. The Names are not evaluated, as in Trace." (do ((names names (cdr names)) (stuff ())) ((null names) ;; Keep the compiler quiet by sending standard output to bit bucket. `(compiler-let (#|(*standard-output* (make-broadcast-stream))|#) ,@stuff (values))) (push (profile-1-function (car names)) stuff))) ;;; A function is profiled by replacing its definition with a closure created by ;;; the following function. The closure records the starting time, calls the ;;; original function, and records finishing time. Other closures are used to ;;; perform various operations on the encapsulated function. (defun profile-1-function (name) (multiple-value-bind (min-args optionals-p) (required-arguments name) (let ((required-args ())) (dotimes (i min-args) (push (gensym) required-args)) `(funcall (compile nil ;; Use ' instead of #' below so guaranteed null lexical environment. '(lambda () (let* ((time 0) (count 0) (consed 0) (old-definition (symbol-function ',name)) (new-definition #'(lambda (,@required-args ,@(if optionals-p `(&rest optional-args))) (incf count) (let ((old-time time) (start-time (quickly-get-time)) (old-consed consed) (start-consed (total-consing))) (multiple-value-prog1 ,(if optionals-p `(apply old-definition ,@required-args optional-args) `(funcall old-definition ,@required-args)) (setq time (+ old-time (- (quickly-get-time) start-time))) (setq consed (+ old-consed (- (total-consing) start-consed)))))))) (pushnew ',name *timed-functions*) (setf (get ',name 'read-time) #'(lambda () (values count time consed)) (get ',name 'reset-time) #'(lambda () (setq count 0) (setq time 0) (setq consed 0) t) (symbol-function ',name) new-definition (get ',name 'reset-definition) #'(lambda () (remprop ',name 'read-time) (remprop ',name 'reset-time) (if (eq (symbol-function ',name) new-definition) (setf (symbol-function ',name) old-definition) (warn "The function ~S was redefined without ~ unprofiling and reprofiling.~%~ Timing figures have not been updated ~ since that redefinition." ',name)) (remprop ',name 'reset-definition) (setq *timed-functions* (delete ',name *timed-functions*)) nil))))))))) (defmacro unprofile (&rest names) "Unwraps the profiling code around the named functions. Names defaults to the list of all currently profiled functions." `(dolist (name ,(if names `',names '*timed-functions*) (values)) (unprofile-1-function name))) (defun unprofile-1-function (name) (if (get name 'reset-definition) (funcall (get name 'reset-definition)) (error "~S is not a function being profiled." name))) (defmacro report-time (&rest names) "Reports the time spent in the named functions. Names defaults to the list of all currently profiled functions." `(%report-times ,(if names `',names '*timed-functions*))) ;;; We average the timing overhead over this many iterations. ;;; (defconstant timer-overhead-iterations 5000) ;;; Compute-Time-Overhead -- Internal ;;; ;;; Return as a float the total number of seconds it takes to call both ;;; Quickly-Get-Time and Total-Consing together, plus a funcall thrown in ;;; to represent some of the other overhead. We also return a something ;;; computed from the results in order to frustrate clever compilers. ;;; (defun compute-time-overhead-aux (x) x) (proclaim '(notinline compute-time-overhead-aux)) ;;; (defun compute-time-overhead () (let ((foo 0) (fun (symbol-function 'compute-time-overhead-aux)) (start (quickly-get-time))) (funcall fun nil) (dotimes (i timer-overhead-iterations) (setq foo (logxor (funcall fun (quickly-get-time)) (total-consing) foo))) (let ((now (quickly-get-time))) (values (/ (float (- now start)) (float timer-overhead-iterations) (float quick-time-units-per-second)) foo)))) (defvar *time-overhead* (compute-time-overhead)) (defstruct (time-info (:constructor make-time-info (name calls time consing))) name calls time consing) (defun %report-times (names) (let ((info ()) (no-call ())) (dolist (name names) (multiple-value-bind (calls time consing) (funcall (or (get name 'read-time) (error "~S is not profiled."))) (if (zerop calls) (push name no-call) (let ((compensated (- (/ (float time) (float quick-time-units-per-second)) (* *time-overhead* (float calls))))) (push (make-time-info name calls (if (minusp compensated) 0.0 compensated) consing) info))))) (setq info (sort info #'>= :key #'time-info-time)) (format *trace-output* "~& Seconds | Consed | Calls | Sec/Call | Name:~@ ------------------------------------------------------~%") (let ((total-time 0.0) (total-consed 0) (total-calls 0)) (dolist (time info) (incf total-time (time-info-time time)) (incf total-calls (time-info-calls time)) (incf total-consed (time-info-consing time)) (format *trace-output* "~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%" (time-info-time time) (time-info-consing time) (time-info-calls time) (/ (time-info-time time) (float (time-info-calls time))) (time-info-name time))) (format *trace-output* "------------------------------------------------------~@ ~10,3F | ~9:D | ~7:D | | Total~%" total-time total-consed total-calls) (format *trace-output* "~%Estimated total profiling overhead: ~4,2F seconds~%" (* *time-overhead* (float total-calls) 2.0))) (when no-call (format *trace-output* "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call #'string< :key #'symbol-name))) (values))) (defmacro reset-time (&rest names) "Resets the time counter for the named functions. Names defaults to the list of all currently profiled functions." `(dolist (name ,(if names `',names '*timed-functions*) (values)) (reset-1-time name))) (defun reset-1-time (name) (if (get name 'reset-time) (funcall (get name 'reset-time)) (error "~S is not a function being profiled."))) cmucl-21a/src/benchmarks/richards/000077500000000000000000000000001260377556400172645ustar00rootroot00000000000000cmucl-21a/src/benchmarks/richards/RICHARDS_MAIL000066400000000000000000000053221260377556400212120ustar00rootroot00000000000000Newsgroups: comp.lang.smalltalk Distribution: comp Subject: Smalltalk vs. C(++) performance Executive summary: a non-trivial benchmark written in C++ and Smalltalk is available from otis.stanford.edu; please send me your results. ------------------------------------------------------------------- As some have pointed out, it is difficult to compare the runtime performance of Smalltalk programs with the performance of equivalent C programs. One reason for this is that for most non-trivial programs there is no equivalent program written in the other language (because it would be a non-trivial effort to write it). The "best" benchmark I know of is the Richards benchmark, an operating system simulation. It is written in an object-oriented style, uses polymorphism, and is reasonably non-trivial (700 lines). It's probably not the world's greatest benchmark, but better than micro-benchamrks, and it is available in Smalltalk, Self, T (an object-oriented version of Scheme) and C++. [Historical note: the Richards benchmark was originally written in BCPL by Mark Richards. Many thanks to L. Peter Deutsch for the Smalltalk version.] The sources for Richards are available from otis.stanford.edu (36.22.0.201) in /pub/benchmarks. I would be interested in comparisons of the performance of the C++ and Smalltalk versions on various systems. We measured it a while ago for the Sun-3/4 versions of PP 2.4, and the difference was about a factor of 10. Disclaimer: Richards is *not* a typical application: it is relatively small and contains no graphics or other user interaction. Thus it may not reflect the relative performance of Your Own Real-World (TM) Application, but I think it tests the efficiency of the basic language mechanisms fairly well. If you think you have a better benchmark which is available both in ST-80 and C (or Fortran or...), please let me know. ******* ADVERTISEMENT ******** The goal of the Self project at Stanford is to improve the performance of dynamically-typed object-oriented languages such as Smalltalk and Self. Though similar to Smalltalk, Self is simpler and more flexible. Our current system runs significantly faster than any Smalltalk implementation we know of. For example, here are the numbers for Richards on a Sun-4/260: C++ (-O2) 730ms Self 2160ms (Nov'90; 1940ms for an experimental system) PP ST-80 2.4 7740ms T 9800ms (8100ms with some not-so-kosher "tuning") [On some other benchmarks, the Stanford Integer Benchmarks, Self actually looks even better, running at around 60-70% of the speed of optimized C.] More information (papers, documentation, how to get the current system) is available via anonymous ftp from otis.stanford.edu. ******* END OF ADVERTISEMENT ******** cmucl-21a/src/benchmarks/richards/cbase.h000066400000000000000000000002431260377556400205110ustar00rootroot00000000000000/* cbase.h */ #ifndef CBASE #define CBASE #define BOOLEAN int #define TRUE 1 #define FALSE 0 #include #include #include #endif cmucl-21a/src/benchmarks/richards/rbase.h000066400000000000000000000005021260377556400205260ustar00rootroot00000000000000/* rbase.h */ #ifndef RBASE #define RBASE typedef enum {DevicePacket, WorkPacket} PacketKind; typedef enum {Idler, Worker, HandlerA, HandlerB, DeviceA, DeviceB} Identity; #define NTASKS 6 /* # elements of Identity */ /* = # of tasks */ #define NoWork NULL #define NoTask NULL #endif cmucl-21a/src/benchmarks/richards/richards.c000066400000000000000000000126161260377556400212350ustar00rootroot00000000000000/* richards.c - Richards Benchmark in C++ */ /* uh 2/2/89 */ #include #define clock_t long /* because Sun library isn't ANSI */ #define CLK_TCK 1000000 #include "richards.h" /* // creation */ void RBench::CreateDevice (Identity id, int prio, Packet *work, TaskState *state) { DeviceTaskRec *data; TaskControlBlock *t; data = new DeviceTaskRec; t = new DeviceTCB(taskList, id, prio, work, state, data); EnterTask(id, t); } void RBench::CreateHandler(Identity id, int prio, Packet *work, TaskState *state) { HandlerTaskRec *data; TaskControlBlock *t; data = new HandlerTaskRec; t = new HandlerTCB(taskList, id, prio, work, state, data); EnterTask(id, t); } void RBench::CreateIdler (Identity id, int prio, Packet *work, TaskState *state) { IdleTaskRec *data; TaskControlBlock *t; data = new IdleTaskRec; t = new IdlerTCB(taskList, id, prio, work, state, data); EnterTask(id, t); } void RBench::CreateWorker (Identity id, int prio, Packet *work, TaskState *state) { WorkerTaskRec *data; TaskControlBlock *t; data = new WorkerTaskRec; t = new WorkerTCB(taskList, id, prio, work, state, data); EnterTask(id, t); } void RBench::EnterTask(Identity id, TaskControlBlock *t) { taskList = t; taskTable[id] = t; } /* //private */ TaskControlBlock *RBench::FindTask(Identity id) { TaskControlBlock *t; t = taskTable[id]; if (t == NULL) printf("***error: FindTask failed! "); return t; } TaskControlBlock *RBench::HoldSelf() { holdCount++; currentTask->SetTaskHolding(TRUE); return currentTask->Link(); } TaskControlBlock *RBench::QueuePacket(Packet *p) { TaskControlBlock *t; t = FindTask(p->Ident()); queuePacketCount++; p->SetLink(NoWork); p->SetIdent(currentTaskIdent); return t->AddPacket(p, currentTask); } TaskControlBlock *RBench::Release(Identity id) { TaskControlBlock *t; t = FindTask(id); t->SetTaskHolding(FALSE); return (t->Priority() > currentTask->Priority()) ? t : currentTask; } void RBench::Trace(Identity id) { if(! --layout) {printf("\n"); layout = 50;} printf("%d", id + 1); } TaskControlBlock *RBench::Wait() { currentTask->SetTaskWaiting(TRUE); return currentTask; } /* //scheduling */ void RBench::Schedule() { currentTask = taskList; while (currentTask != NoTask) { if (currentTask->IsTaskHoldingOrWaiting()) currentTask = currentTask->Link(); else { currentTaskIdent = currentTask->Ident(); if (tracing) Trace(currentTaskIdent); currentTask = currentTask->RunTask(); } } } /* //initializing */ void RBench::InitScheduler() { queuePacketCount = 0; holdCount = 0; for (int i = 0; i < NTASKS; i++) {taskTable[i] = NoTask;} taskList = NoTask; } void RBench::InitTrace() { char c; printf("Trace (y/n)? "); c = getchar(); tracing = (_toupper(c) == 'Y'); } void RBench::Start(BOOLEAN trace) { // clock_t t1, t2, t3, t4; TaskState *t; Packet *workQ; if (trace) InitTrace(); else tracing = FALSE; InitScheduler(); // t1 = clock(); // printf("\nRichards benchmark: initializing...\n"); t = new TaskState; t->Running(); // Idler CreateIdler(Idler, 0, NoWork, t); workQ = new Packet(NoWork, Worker, WorkPacket); // Worker workQ = new Packet(workQ , Worker, WorkPacket); t = new TaskState; t->WaitingWithPacket(); CreateWorker(Worker, 1000, workQ, t); workQ = new Packet(NoWork, DeviceA, DevicePacket); // HandlerA workQ = new Packet(workQ , DeviceA, DevicePacket); workQ = new Packet(workQ , DeviceA, DevicePacket); t = new TaskState; t->WaitingWithPacket(); CreateHandler(HandlerA, 2000, workQ, t); workQ = new Packet(NoWork, DeviceB, DevicePacket); // HandlerB workQ = new Packet(workQ , DeviceB, DevicePacket); workQ = new Packet(workQ , DeviceB, DevicePacket); t = new TaskState; t->WaitingWithPacket(); CreateHandler(HandlerB, 3000, workQ, t); t = new TaskState; t->Waiting(); // DeviceA CreateDevice(DeviceA, 4000, NoWork, t); t = new TaskState; t->Waiting(); // DeviceB CreateDevice(DeviceB, 5000, NoWork, t); // printf("starting...\n"); // t2 = clock(); Schedule(); // t3 = clock(); // printf("done.\n"); // printf("QueuePacketCount = %d, HoldCount = %d.\nThese results are %s", // queuePacketCount, holdCount, // (queuePacketCount == 23246 && holdCount == 9297) ? // "correct." : "wrong!" // ); if (! (queuePacketCount == 23246 && holdCount == 9297)) { printf("error: richards results are incorrect\n"); } // t4 = clock(); // printf("\nScheduler time = %g seconds, total time = %g\n", // (double)(t3 - t2) / CLK_TCK, // (double)(t4 - t1) / CLK_TCK); } #define ITER 10 /* # of iterations in main loop */ int main() { clock_t t_start, t_stop; t_start = clock(); for (int i = 0; i < ITER; i++) bm.Start(ITER == 1); t_stop = clock(); clock_t diff = (t_stop - t_start)/ITER; printf("richards: %d ms\n", diff/(CLK_TCK/1000)); // if (ITER > 1) // printf("\n*** %d iterations, average of %g secs / iteration.\n", // ITER, // (double)(t_stop - t_start) / (ITER * CLK_TCK)); } cmucl-21a/src/benchmarks/richards/richards.h000066400000000000000000000027401260377556400212370ustar00rootroot00000000000000/* richards.h */ /* Richards benchmark in C++, translated from Smalltalk */ /* uh 2/2/89 */ #include "rbase.h" #include "tasks.h" /* // RBench class definition */ class RBench { private: TaskControlBlock *taskList, *currentTask; Identity currentTaskIdent; TaskControlBlock *taskTable[NTASKS]; int layout; int holdCount, queuePacketCount; /* creation */ void CreateDevice (Identity id, int prio, Packet *work, TaskState *state); void CreateHandler(Identity id, int prio, Packet *work, TaskState *state); void CreateIdler (Identity id, int prio, Packet *work, TaskState *state); void CreateWorker (Identity id, int prio, Packet *work, TaskState *state); void EnterTask(Identity id, TaskControlBlock *t); /* scheduling */ void Schedule(); /* initializing */ void InitScheduler(); void InitTrace(); public: /* task management */ TaskControlBlock *FindTask(Identity id); TaskControlBlock *HoldSelf(); TaskControlBlock *QueuePacket(Packet *p); TaskControlBlock *Release(Identity id); TaskControlBlock *Wait(); /* tracing */ BOOLEAN tracing; void Trace(Identity id); void Start(BOOLEAN askTrace); }; RBench bm; // benchmark currently executing cmucl-21a/src/benchmarks/richards/richards.lisp000066400000000000000000000307531260377556400217640ustar00rootroot00000000000000(in-package "USER") #+declare-unsafe (proclaim '(optimize speed (space 0) (safety 0) (compilation-speed 0))) (defconstant deviceA 5) (defconstant deviceB 6) (defconstant devicePacketKind 1) (defconstant handlerA 3) (defconstant handlerB 4) (defconstant idler 1) (defconstant noWork nil) (defconstant noTask nil) (defconstant worker 2) (defconstant workPacketKind 2) (defvar taskList noTask) (defvar currentTask nil) (defvar currentTaskIdentity nil) (defvar taskTable (make-array 6 :initial-element noTask)) (proclaim '(simple-vector taskTable)) (defvar tracing nil) (defvar layout 0) (defvar queuePacketCount 0) (defvar holdCount 0) (proclaim '(fixnum layout queuePacketCount holdCount)) (declaim (inline make-taskControlBlock make-packet make-deviceTaskDataRecord make-handlerTaskDataRecord make-idleTaskDataRecord make-workerTaskDataRecord wait)) (defstruct (taskControlBlock (:constructor make-taskControlBLock ())) packetPending taskWaiting taskHolding link identity (priority 0 :type fixnum) input state handle) (defstruct (packet (:constructor make-packet ())) link identity (kind 0 :type fixnum) (datum 0 :type fixnum) (data '#() :type simple-vector)) (defstruct (deviceTaskDataRecord (:constructor make-deviceTaskDataRecord ())) pending) (defstruct (handlerTaskDataRecord (:constructor make-handlerTaskDataRecord ())) workIn deviceIn) (defstruct (idleTaskDataRecord (:constructor make-idleTaskDataRecord ())) (control 0 :type fixnum) (count 0 :type fixnum)) (defstruct (workerTaskDataRecord (:constructor make-workerTaskDataRecord ())) (destination 0 :type fixnum) (count 0 :type fixnum)) (defun wait () (setf (taskControlBlock-taskWaiting currentTask) t) currentTask) #+cmu (declaim (ext:freeze-type taskControlBlock packet deviceTaskDataRecord handlerTaskDataRecord idleTaskDataRecord workerTaskDataRecord)) #+cmu (declaim (ext:start-block richards)) (defun deviceTaskDataRecord-run (self work) (let ((functionWork work)) (if (eq noWork functionWork) (progn (setq functionWork (deviceTaskDataRecord-pending self)) (if (eq noWork functionWork) (wait) (progn (setf (deviceTaskDataRecord-pending self) noWork) (queuePacket functionWork)))) (progn (setf (deviceTaskDataRecord-pending self) functionWork) (if tracing (trace-it (packet-datum functionWork))) (holdSelf))))) (defun handlerTaskDataRecord-run (self work) (if (eq noWork work) nil (if (= workPacketKind (packet-kind work)) (workInAdd self work) (deviceInAdd self work))) (let ((workPacket (handlerTaskDataRecord-workIn self))) (if (eq noWork workPacket) (wait) (let ((count (packet-datum workPacket))) (if (> count 4) (progn (setf (handlerTaskDataRecord-workIn self) (packet-link workPacket)) (queuePacket workPacket)) (let ((devicePacket (handlerTaskDataRecord-deviceIn self))) (if (eq noWork devicePacket) (wait) (progn (setf (handlerTaskDataRecord-deviceIn self) (packet-link devicePacket)) (setf (packet-datum devicePacket) (svref (packet-data workPacket) (- count 1))) (setf (packet-datum workPacket) (+ count 1)) (queuePacket devicePacket))))))))) (defun idleTaskDataRecord-run (self work) (declare (ignore work)) (setf (idleTaskDataRecord-count self) (- (idleTaskDataRecord-count self) 1)) (if (= 0 (idleTaskDataRecord-count self)) (holdSelf) (if (= 0 (logand (idleTaskDataRecord-control self) 1)) (progn (setf (idleTaskDataRecord-control self) (floor (idleTaskDataRecord-control self) 2)) (release deviceA)) (progn (setf (idleTaskDataRecord-control self) (logxor (floor (idleTaskDataRecord-control self) 2) 53256)) (release deviceB))))) (defun workerTaskDataRecord-run (self work) (if (eq noWork work) (wait) (progn (setf (workerTaskDataRecord-destination self) (if (= handlerA (workerTaskDataRecord-destination self)) handlerB handlerA)) (setf (packet-identity work) (workerTaskDataRecord-destination self)) (setf (packet-datum work) 1) (do ((i 0 (+ i 1))) ((> i 3) nil) (declare (fixnum i)) (setf (workerTaskDataRecord-count self) (+ (workerTaskDataRecord-count self) 1)) (if (> (workerTaskDataRecord-count self) 256) (setf (workerTaskDataRecord-count self) 1)) (setf (svref (packet-data work) i) (the fixnum (+ (char-code #\A) (- (workerTaskDataRecord-count self) 1))))) (queuePacket work)))) (defun appendHead (packet queueHead) (setf (packet-link packet) noWork) (if (eq noWork queueHead) packet (let ((mouse queueHead)) (let ((link (packet-link mouse))) (do () ((eq noWork link) nil) (setq mouse link) (setq link (packet-link mouse))) (setf (packet-link mouse) packet) queueHead)))) (defun initialize-globals () (setq taskList noTask) (setq currentTask nil) (setq currentTaskIdentity nil) (setq taskTable (make-array 6 :initial-element noTask)) (setq tracing nil) (setq layout 0) (setq queuePacketCount 0) (setq holdCount 0)) (defun richards () (initialize-globals) (createIdler idler 0 noWork (running (make-taskControlBlock))) (let ((workQ)) (setq workQ (createPacket noWork worker workPacketKind)) (setq workQ (createPacket workQ worker workPacketKind)) (createWorker worker 1000 workQ (waitingWithPacket)) (setq workQ (createPacket noWork deviceA devicePacketKind)) (setq workQ (createPacket workQ deviceA devicePacketKind)) (setq workQ (createPacket workQ deviceA devicePacketKind)) (createHandler handlerA 2000 workQ (waitingWithPacket)) (setq workQ (createPacket noWork deviceB devicePacketKind)) (setq workQ (createPacket workQ deviceB devicePacketKind)) (setq workQ (createPacket workQ deviceB devicePacketKind)) (createHandler handlerB 3000 workQ (waitingWithPacket)) (createDevice deviceA 4000 noWork (waiting)) (createDevice deviceB 5000 noWork (waiting)) ) (schedule) (if (not (and (= queuePacketCount 23246) (= holdCount 9297))) (error "richards results incorrect")) nil) (defun schedule () (setq currentTask taskList) (do () ((eq noTask currentTask) nil) (if (isTaskHoldingOrWaiting currentTask) (setq currentTask (taskControlBlock-link currentTask)) (progn (setq currentTaskIdentity (taskControlBlock-identity currentTask)) (if tracing (trace-it currentTaskIdentity)) (setq currentTask (runTask currentTask)))))) (defun findTask (identity) (declare (fixnum identity)) (let ((tk (svref taskTable (- identity 1)))) (if (eq noTask tk) (error "findTask failed")) tk)) (defun holdSelf () (setq holdCount (+ holdCount 1)) (setf (taskControlBlock-taskHolding currentTask) t) (taskControlBlock-link currentTask)) (defun queuePacket (packet) (let ((tk (findTask (packet-identity packet)))) (if (eq noTask tk) noTask (progn (setq queuePacketCount (+ queuePacketCount 1)) (setf (packet-link packet) noWork) (setf (packet-identity packet) currentTaskIdentity) (addInput tk packet currentTask))))) (defun release (identity) (let ((tk (findTask identity))) (if (eq noTask tk) noTask (progn (setf (taskControlBlock-taskHolding tk) nil) (if (> (taskControlBlock-priority tk) (taskControlBlock-priority currentTask)) tk currentTask))))) (defun trace-it (id) (setq layout (- layout 1)) (if (>= 0 layout) (progn (format t "~%") (setq layout 30))) (format t "~a " id)) (defun createDevice (identity priority work state) (let ((data (create-deviceTaskDataRecord))) (createTask identity priority work state data))) (defun createHandler (identity priority work state) (let ((data (create-handlerTaskDataRecord))) (createTask identity priority work state data))) (defun createIdler (identity priority work state) (let ((data (create-idleTaskDataRecord))) (createTask identity priority work state data))) (defun createWorker (identity priority work state) (let ((data (create-workerTaskDataRecord))) (createTask identity priority work state data))) (defun createTask (identity priority work state data) (let ((tk (create-taskControlBlock taskList identity priority work state data))) (setq taskList tk) (setf (svref taskTable (- identity 1)) tk))) (defun createPacket (link identity kind) (create-packet link identity kind)) (defun running (tcb) (setf (taskControlBlock-packetPending tcb) nil) (setf (taskControlBlock-taskWaiting tcb) nil) (setf (taskControlBlock-taskHolding tcb) nil) tcb) (defun waiting () (let ((tcb (make-taskControlBlock))) (setf (taskControlBlock-packetPending tcb) nil) (setf (taskControlBlock-taskWaiting tcb) t) (setf (taskControlBlock-taskHolding tcb) nil) tcb)) (defun waitingWithPacket () (let ((tcb (make-taskControlBlock))) (setf (taskControlBlock-packetPending tcb) t) (setf (taskControlBlock-taskWaiting tcb) t) (setf (taskControlBlock-taskHolding tcb) nil) tcb)) (defun isTaskHoldingOrWaiting (tcb) (or (taskControlBlock-taskHolding tcb) (and (not (taskControlBlock-packetPending tcb)) (taskControlBlock-taskWaiting tcb)))) (defun isWaitingWithPacket (tcb) (and (taskControlBlock-packetPending tcb) (and (taskControlBlock-taskWaiting tcb) (not (taskControlBlock-taskHolding tcb))))) (defun packetNowPending (tcb) (setf (taskControlBlock-packetPending tcb) t) (setf (taskControlBlock-taskWaiting tcb) nil) (setf (taskControlBlock-taskHolding tcb) nil) tcb) (defun create-taskControlBlock (link identity priority initialWorkQueue initialState privateData) (let ((r (make-taskControlBlock))) (setf (taskControlBlock-link r) link) (setf (taskControlBlock-identity r) identity) (setf (taskControlBlock-priority r) priority) (setf (taskControlBlock-input r) initialWorkQueue) (setf (taskControlBlock-packetPending r) (taskControlBlock-packetPending initialState)) (setf (taskControlBlock-taskWaiting r) (taskControlBlock-taskWaiting initialState)) (setf (taskControlBlock-taskHolding r) (taskControlBlock-taskHolding initialState)) (setf (taskControlBlock-handle r) privateData) (setf (taskControlBlock-state r) nil) r)) (defun addInput (tcb packet oldTask) (if (eq noWork (taskControlBlock-input tcb)) (progn (setf (taskControlBlock-input tcb) packet) (setf (taskControlBlock-packetPending tcb) t) (if (> (taskControlBlock-priority tcb) (taskControlBlock-priority oldTask)) tcb oldTask)) (progn (setf (taskControlBlock-input tcb) (appendHead packet (taskControlBlock-input tcb))) oldTask))) (defun runTask (tcb) (let ((message nil)) (if (isWaitingWithPacket tcb) (progn (setq message (taskControlBlock-input tcb)) (setf (taskControlBlock-input tcb) (packet-link message)) (if (eq noWork (taskControlBlock-input tcb)) (running tcb) (packetNowPending tcb))) (setq message noWork)) (run (taskControlBlock-handle tcb) message))) (defun run (self work) (typecase self (deviceTaskDataRecord (deviceTaskDataRecord-run self work)) (handlerTaskDataRecord (handlerTaskDataRecord-run self work)) (idleTaskDataRecord (idleTaskDataRecord-run self work)) (workerTaskDataRecord (workerTaskDataRecord-run self work)))) (defun create-packet (link identity kind) (let ((p (make-packet))) (setf (packet-link p) link) (setf (packet-identity p) identity) (setf (packet-kind p) kind) (setf (packet-datum p) 1) (let ((v (make-array 4 :initial-element 0))) (setf (packet-data p) v)) p)) (defun create-deviceTaskDataRecord () (let ((tk (make-deviceTaskDataRecord))) (setf (deviceTaskDataRecord-pending tk) noWork) tk)) (defun create-handlerTaskDataRecord () (let ((tk (make-handlerTaskDataRecord))) (setf (handlerTaskDataRecord-workIn tk) noWork) (setf (handlerTaskDataRecord-deviceIn tk) noWork) tk)) (defun deviceInAdd (tk packet) (setf (handlerTaskDataRecord-deviceIn tk) (appendHead packet (handlerTaskDataRecord-deviceIn tk))) tk) (defun workInAdd (tk packet) (setf (handlerTaskDataRecord-workIn tk) (appendHead packet (handlerTaskDataRecord-workIn tk))) tk) (defun create-idleTaskDataRecord () (let ((tk (make-idleTaskDataRecord))) (setf (idleTaskDataRecord-control tk) 1) (setf (idleTaskDataRecord-count tk) 10000) tk)) (defun create-workerTaskDataRecord () (let ((tk (make-workerTaskDataRecord))) (setf (workerTaskDataRecord-destination tk) handlerA) (setf (workerTaskDataRecord-count tk) 0) tk)) cmucl-21a/src/benchmarks/richards/richards.t000066400000000000000000000262301260377556400212530ustar00rootroot00000000000000(herald richards) (define deviceA 5) (define deviceB 6) (define devicePacketKind 1) (define handlerA 3) (define handlerB 4) (define idler 1) (define noWork nil) (define noTask nil) (define worker 2) (define workPacketKind 2) (lset taskList noTask) (lset currentTask nil) (lset currentTaskIdentity nil) (lset taskTable (make-vector 6)) (lset tracing nil) (lset layout 0) (lset queuePacketCount 0) (lset holdCount 0) (define-operation (run self work)) (vector-fill taskTable noTask) (define (hash-obj l) (if l (object-hash l) nil)) (define-structure-type taskControlBlock packetPending taskWaiting taskHolding link identity priority input state handle) (define-structure-type packet link identity kind datum data) (define-structure-type deviceTaskDataRecord pending (((run self work) (lset functionWork work) (if (equal? noWork functionWork) (block (set functionWork (deviceTaskDataRecord-pending self)) (if (equal? noWork functionWork) (wait) (block (set (deviceTaskDataRecord-pending self) noWork) (queuePacket functionWork)))) (block (set (deviceTaskDataRecord-pending self) functionWork) (if tracing (trace (packet-datum functionWork))) (holdSelf)))))) (define-structure-type handlerTaskDataRecord workIn deviceIn (((run self work) (if (equal? noWork work) nil (if (equal? workPacketKind (packet-kind work)) (workInAdd self work) (deviceInAdd self work))) (let ((workPacket (handlerTaskDataRecord-workIn self))) (if (equal? noWork workPacket) (wait) (let ((count (packet-datum workPacket))) (if (> count 4) (block (set (handlerTaskDataRecord-workIn self) (packet-link workPacket)) (queuePacket workPacket)) (let ((devicePacket (handlerTaskDataRecord-deviceIn self))) (if (equal? noWork devicePacket) (wait) (block (set (handlerTaskDataRecord-deviceIn self) (packet-link devicePacket)) (set (packet-datum devicePacket) (vref (packet-data workPacket) (- count 1))) (set (packet-datum workPacket) (+ count 1)) (queuePacket devicePacket))))))))))) (define-structure-type idleTaskDataRecord control count (((run self work) (ignorable work) (set (idleTaskDataRecord-count self) (- (idleTaskDataRecord-count self) 1)) (if (equal? 0 (idleTaskDataRecord-count self)) (holdSelf) (if (equal? 0 (logand (idleTaskDataRecord-control self) 1)) (block (set (idleTaskDataRecord-control self) (quotient (idleTaskDataRecord-control self) 2)) (release deviceA)) (block (set (idleTaskDataRecord-control self) (logxor (quotient (idleTaskDataRecord-control self) 2) 53256)) (release deviceB))))))) (define-structure-type workerTaskDataRecord destination count (((run self work) (if (equal? noWork work) (wait) (block (set (workerTaskDataRecord-destination self) (if (equal? handlerA (workerTaskDataRecord-destination self)) handlerB handlerA)) (set (packet-identity work) (workerTaskDataRecord-destination self)) (set (packet-datum work) 1) (do ((i 0 (+ i 1))) ((> i 3) nil) (set (workerTaskDataRecord-count self) (+ (workerTaskDataRecord-count self) 1)) (if (> (workerTaskDataRecord-count self) 256) (set (workerTaskDataRecord-count self) 1)) (vset (packet-data work) i (+ (char->ascii #\A) (- (workerTaskDataRecord-count self) 1)))) (queuePacket work)))))) (define (appendHead packet queueHead) (set (packet-link packet) noWork) (if (equal? noWork queueHead) packet (block (lset mouse queueHead) (lset link (packet-link mouse)) (do () ((equal? noWork link) nil) (set mouse link) (set link (packet-link mouse))) (set (packet-link mouse) packet) queueHead))) (define (initialize-globals) (set taskList noTask) (set currentTask nil) (set currentTaskIdentity nil) (set taskTable (make-vector 6)) (set tracing nil) (set layout 0) (set queuePacketCount 0) (set holdCount 0) (vector-fill taskTable noTask)) (define (richards) (initialize-globals) (createIdler idler 0 noWork (running (make-taskControlBlock))) (lset workQ (createPacket noWork worker workPacketKind)) (set workQ (createPacket workQ worker workPacketKind)) (createWorker worker 1000 workQ (waitingWithPacket)) (set workQ (createPacket noWork deviceA devicePacketKind)) (set workQ (createPacket workQ deviceA devicePacketKind)) (set workQ (createPacket workQ deviceA devicePacketKind)) (createHandler handlerA 2000 workQ (waitingWithPacket)) (set workQ (createPacket noWork deviceB devicePacketKind)) (set workQ (createPacket workQ deviceB devicePacketKind)) (set workQ (createPacket workQ deviceB devicePacketKind)) (createHandler handlerB 3000 workQ (waitingWithPacket)) (createDevice deviceA 4000 noWork (waiting)) (createDevice deviceB 5000 noWork (waiting)) (schedule) (if (not (and (equal? queuePacketCount 23246) (equal? holdCount 9297))) (error "richards results incorrect")) nil) (define (schedule) (set currentTask taskList) (do () ((equal? noTask currentTask) nil) (if (isTaskHoldingOrWaiting currentTask) (set currentTask (taskControlBlock-link currentTask)) (block (set currentTaskIdentity (taskControlBlock-identity currentTask)) (if tracing (trace currentTaskIdentity)) (set currentTask (runTask currentTask)))))) (define (findTask identity) (let ((tk (vref taskTable (- identity 1)))) (if (equal? noTask tk) (error "findTask failed")) tk)) (define (holdSelf) (set holdCount (+ holdCount 1)) (set (taskControlBlock-taskHolding currentTask) t) (taskControlBlock-link currentTask)) (define (queuePacket packet) (let ((tk (findTask (packet-identity packet)))) (if (equal? noTask tk) noTask (block (set queuePacketCount (+ queuePacketCount 1)) (set (packet-link packet) noWork) (set (packet-identity packet) currentTaskIdentity) (addInput tk packet currentTask))))) (define (release identity) (let ((tk (findTask identity))) (if (equal? noTask tk) noTask (block (set (taskControlBlock-taskHolding tk) nil) (if (> (taskControlBlock-priority tk) (taskControlBlock-priority currentTask)) tk currentTask))))) (define (trace id) (set layout (- layout 1)) (if (>= 0 layout) (block (format (debug-output) "~%") (set layout 30))) (format (debug-output) "~a " id)) (define (wait) (set (taskControlBlock-taskWaiting currentTask) t) currentTask) (define (createDevice identity priority work state) (let ((data (create-deviceTaskDataRecord))) (createTask identity priority work state data))) (define (createHandler identity priority work state) (let ((data (create-handlerTaskDataRecord))) (createTask identity priority work state data))) (define (createIdler identity priority work state) (let ((data (create-idleTaskDataRecord))) (createTask identity priority work state data))) (define (createWorker identity priority work state) (let ((data (create-workerTaskDataRecord))) (createTask identity priority work state data))) (define (createTask identity priority work state data) (let ((tk (create-taskControlBlock taskList identity priority work state data))) (set taskList tk) (vset taskTable (- identity 1) tk))) (define (createPacket link identity kind) (create-packet link identity kind)) (define (running tcb) (set (taskControlBlock-packetPending tcb) nil) (set (taskControlBlock-taskWaiting tcb) nil) (set (taskControlBlock-taskHolding tcb) nil) tcb) (define (waiting) (let ((tcb (make-taskControlBlock))) (set (taskControlBlock-packetPending tcb) nil) (set (taskControlBlock-taskWaiting tcb) t) (set (taskControlBlock-taskHolding tcb) nil) tcb)) (define (waitingWithPacket) (let ((tcb (make-taskControlBlock))) (set (taskControlBlock-packetPending tcb) t) (set (taskControlBlock-taskWaiting tcb) t) (set (taskControlBlock-taskHolding tcb) nil) tcb)) (define (isTaskHoldingOrWaiting tcb) (or (taskControlBlock-taskHolding tcb) (and (not (taskControlBlock-packetPending tcb)) (taskControlBlock-taskWaiting tcb)))) (define (isWaitingWithPacket tcb) (and (taskControlBlock-packetPending tcb) (and (taskControlBlock-taskWaiting tcb) (not (taskControlBlock-taskHolding tcb))))) (define (packetNowPending tcb) (set (taskControlBlock-packetPending tcb) t) (set (taskControlBlock-taskWaiting tcb) nil) (set (taskControlBlock-taskHolding tcb) nil) tcb) (define (create-taskControlBlock link identity priority initialWorkQueue initialState privateData) (let ((r (make-taskControlBlock))) (set (taskControlBlock-link r) link) (set (taskControlBlock-identity r) identity) (set (taskControlBlock-priority r) priority) (set (taskControlBlock-input r) initialWorkQueue) (set (taskControlBlock-packetPending r) (taskControlBlock-packetPending initialState)) (set (taskControlBlock-taskWaiting r) (taskControlBlock-taskWaiting initialState)) (set (taskControlBlock-taskHolding r) (taskControlBlock-taskHolding initialState)) (set (taskControlBlock-handle r) privateData) (set (taskControlBlock-state r) nil) r)) (define (addInput tcb packet oldTask) (if (equal? noWork (taskControlBlock-input tcb)) (block (set (taskControlBlock-input tcb) packet) (set (taskControlBlock-packetPending tcb) t) (if (> (taskControlBlock-priority tcb) (taskControlBlock-priority oldTask)) tcb oldTask)) (block (set (taskControlBlock-input tcb) (appendHead packet (taskControlBlock-input tcb))) oldTask))) (define (runTask tcb) (lset message nil) (if (isWaitingWithPacket tcb) (block (set message (taskControlBlock-input tcb)) (set (taskControlBlock-input tcb) (packet-link message)) (if (equal? noWork (taskControlBlock-input tcb)) (running tcb) (packetNowPending tcb))) (set message noWork)) (run (taskControlBlock-handle tcb) message)) (define (create-packet link identity kind) (let ((p (make-packet))) (set (packet-link p) link) (set (packet-identity p) identity) (set (packet-kind p) kind) (set (packet-datum p) 1) (let ((v (make-vector 4))) (vector-fill v 0) (set (packet-data p) v)) p)) (define (create-deviceTaskDataRecord) (let ((tk (make-deviceTaskDataRecord))) (set (deviceTaskDataRecord-pending tk) noWork) tk)) (define (create-handlerTaskDataRecord) (let ((tk (make-handlerTaskDataRecord))) (set (handlerTaskDataRecord-workIn tk) noWork) (set (handlerTaskDataRecord-deviceIn tk) noWork) tk)) (define (deviceInAdd tk packet) (set (handlerTaskDataRecord-deviceIn tk) (appendHead packet (handlerTaskDataRecord-deviceIn tk))) tk) (define (workInAdd tk packet) (set (handlerTaskDataRecord-workIn tk) (appendHead packet (handlerTaskDataRecord-workIn tk))) tk) (define (create-idleTaskDataRecord) (let ((tk (make-idleTaskDataRecord))) (set (idleTaskDataRecord-control tk) 1) (set (idleTaskDataRecord-count tk) 10000) tk)) (define (create-workerTaskDataRecord) (let ((tk (make-workerTaskDataRecord))) (set (workerTaskDataRecord-destination tk) handlerA) (set (workerTaskDataRecord-count tk) 0) tk)) cmucl-21a/src/benchmarks/richards/tasks.c000066400000000000000000000075201260377556400205610ustar00rootroot00000000000000/* tasks.c */ #include "tasks.h" #include "richards.h" /* // TaskControlBlock */ TaskControlBlock::TaskControlBlock(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData) { link = l; ident = id; priority = prio; input = initialWork; packetPending = initialState->IsPacketPending(); taskWaiting = initialState->IsTaskWaiting(); taskHolding = initialState->IsTaskHolding(); handle = privateData; } TaskControlBlock *TaskControlBlock::AddPacket(Packet *p, TaskControlBlock *oldTask) { if (input == NoWork) { input = p; packetPending = TRUE; if (priority > oldTask->priority) return this; } else AddToList(input, p); return oldTask; } TaskControlBlock *TaskControlBlock::RunTask() { Packet *msg; if (IsWaitingWithPacket()) { msg = input; input = input->Link(); if (input == NoWork) Running(); else PacketPending(); } else msg = NoWork; return this->ActionFunc(msg, handle); } /* // action functions */ TaskControlBlock *TaskControlBlock::ActionFunc(Packet *p, void *handle) { p, handle, 0; printf("***error: virtual TaskControlBlock.ActionFunc called!\n"); return NoTask; } TaskControlBlock *DeviceTCB::ActionFunc(Packet *p, void *handle) { DeviceTaskRec *data = (DeviceTaskRec *)handle; if (p == NoWork) { if ((p = data->Pending()) == NoWork) return bm.Wait(); else { data->SetPending(NoWork); return bm.QueuePacket(p); } } else { data->SetPending(p); if (bm.tracing) bm.Trace(p->Datum()); return bm.HoldSelf(); } } TaskControlBlock *HandlerTCB::ActionFunc(Packet *p, void *handle) { HandlerTaskRec *data = (HandlerTaskRec *)handle; Packet *work, *devicePacket; int count; if (p != NoWork) { if (p->Kind() == WorkPacket) data->WorkInAdd(p); else data->DeviceInAdd(p); } if ((work = data->WorkIn()) == NoWork) return bm.Wait(); else { count = work->Datum(); if (count > 4) { data->SetWorkIn(work->Link()); return bm.QueuePacket(work); } else { if ((devicePacket = data->DeviceIn()) == NoWork) return bm.Wait(); else { data->SetDeviceIn(devicePacket->Link()); devicePacket->SetDatum(work->Data()[count-1]); work->SetDatum(count + 1); return bm.QueuePacket(devicePacket); } } } } TaskControlBlock *IdlerTCB::ActionFunc(Packet *p, void *handle) /* p is not used here */ { IdleTaskRec *data = (IdleTaskRec *)handle; p, 0; data->SetCount(data->Count() - 1); if (data->Count() == 0) return bm.HoldSelf(); else if ((data->Control() & 1) == 0) { data->SetControl(data->Control() / 2); return bm.Release(DeviceA); } else { data->SetControl((data->Control() / 2) ^ 53256); return bm.Release(DeviceB); } } TaskControlBlock *WorkerTCB::ActionFunc(Packet *p, void *handle) { WorkerTaskRec *data = (WorkerTaskRec *)handle; Identity dest; if (p == NoWork) return bm.Wait(); else { dest = (data->Destination() == HandlerA) ? HandlerB : HandlerA; data->SetDestination(dest); p->SetIdent(dest); p->SetDatum(1); for(int i = 0; i < 4; i++) { data->SetCount(data->Count() + 1); if (data->Count() > 26) data->SetCount(1); p->Data()[i] = 'A' + data->Count(); } return bm.QueuePacket(p); } } cmucl-21a/src/benchmarks/richards/tasks.h000066400000000000000000000071511260377556400205660ustar00rootroot00000000000000/* tasks.h - definitions of TaskState, TaskControlBlock and xxxTCB * The subclasses of TaskControlBlock differ only in their * implementation of the action function */ #ifndef TASKS #define TASKS #include "types.h" /* // TaskState */ class TaskState { protected: BOOLEAN packetPending, taskWaiting, taskHolding; public: /* initializing */ TaskState() {packetPending = TRUE; taskWaiting = taskHolding = FALSE;} void PacketPending() {packetPending = TRUE; taskHolding = taskWaiting = FALSE;} void Waiting() {packetPending = taskHolding = FALSE; taskWaiting = TRUE;} void Running() {packetPending = taskWaiting = taskHolding = FALSE;} void WaitingWithPacket() {packetPending = taskWaiting = TRUE; taskHolding = FALSE;} /* accessing */ BOOLEAN IsPacketPending() {return packetPending;} BOOLEAN IsTaskWaiting() {return taskWaiting;} BOOLEAN IsTaskHolding() {return taskHolding;} void SetTaskHolding(BOOLEAN state) {taskHolding = state;} void SetTaskWaiting(BOOLEAN state) {taskWaiting = state;} /* testing */ BOOLEAN IsRunning() {return !packetPending && !taskWaiting && !taskHolding;} BOOLEAN IsTaskHoldingOrWaiting() {return taskHolding || !packetPending && taskWaiting;} BOOLEAN IsWaiting() {return !packetPending && taskWaiting && !taskHolding;} BOOLEAN IsWaitingWithPacket() {return packetPending && taskWaiting && !taskHolding;} }; /* // TaskControlBlock */ class TaskControlBlock : public TaskState { protected: TaskControlBlock *link; Identity ident; int priority; Packet *input; void *handle; public: /* initializing */ TaskControlBlock(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData); /* accessing */ Identity Ident() {return ident;} int Priority() {return priority;} TaskControlBlock *Link() {return link;} /* scheduling */ TaskControlBlock *AddPacket(Packet *p, TaskControlBlock *old); virtual TaskControlBlock *ActionFunc(Packet *p, void *handle); TaskControlBlock *RunTask(); }; /* // DeviceTCB */ class DeviceTCB : public TaskControlBlock { public: DeviceTCB(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData) : (l, id, prio, initialWork, initialState, privateData){} TaskControlBlock *ActionFunc(Packet *p, void *handle); }; /* // HandlerTCB */ class HandlerTCB : public TaskControlBlock { public: HandlerTCB(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData) : (l, id, prio, initialWork, initialState, privateData){} TaskControlBlock *ActionFunc(Packet *p, void *handle); }; /* // IdlerTCB */ class IdlerTCB : public TaskControlBlock { public: IdlerTCB(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData) : (l, id, prio, initialWork, initialState, privateData){} TaskControlBlock *ActionFunc(Packet *p, void *handle); }; /* // WorkerTCB */ class WorkerTCB : public TaskControlBlock { public: WorkerTCB(TaskControlBlock *l, Identity id, int prio, Packet *initialWork, TaskState *initialState, void *privateData) : (l, id, prio, initialWork, initialState, privateData){} TaskControlBlock *ActionFunc(Packet *p, void *handle); }; #endif cmucl-21a/src/benchmarks/richards/types.c000066400000000000000000000010361260377556400205740ustar00rootroot00000000000000/* types.c */ #include "types.h" /* // AddToList - list utility (append elem at end of list, return head) */ Packet *AddToList(Packet *list, Packet *elem) { Packet *p, *next; elem->SetLink(NoWork); if (list != NoWork) { p = list; while((next = p->Link()) != NoWork) p = next; p->SetLink(elem); } else list = elem; return list; } Packet::Packet(Packet *l, Identity id, PacketKind k) { link = l; ident = id; kind = k; datum = 1; for(int i = 0; i < 4; i++) data[i] = 0; } cmucl-21a/src/benchmarks/richards/types.h000066400000000000000000000044351260377556400206070ustar00rootroot00000000000000/* types.h -- basic classes (Packet, {Device,Idle,...}TaskRec) */ #include "cbase.h" #include "rbase.h" /* // Packet */ class Packet { private: Packet *link; // next packet in queue Identity ident; // Idle, Worker, DeviceA, ... PacketKind kind; // DevicePacket or WorkPacket int datum; char data[4]; public: Packet(Packet *l, Identity id, PacketKind k); char *Data() {return data;} void SetData(char d[4]) {for(int i=0; i < 4; i++) data[i] = d[i];} int Datum() {return datum;} void SetDatum(int n) {datum = n;} Identity Ident() {return ident;} void SetIdent(Identity i) {ident = i;} PacketKind Kind() {return kind;} void SetKind(PacketKind k) {kind = k;} Packet *Link() {return link;} void SetLink(Packet *l) {link = l;} }; /* // AddToList - list utility (append elem at end of list, return head) */ Packet *AddToList(Packet *list, Packet *elem); /* // DeviceTaskRec */ class DeviceTaskRec { private: Packet *pending; public: DeviceTaskRec() {pending = NoWork;} Packet *Pending() {return pending;} void SetPending(Packet *p) {pending = p;} }; /* // IdleTaskRec */ class IdleTaskRec { private: int control, count; public: IdleTaskRec() {control = 1; count = 10000;} int Control() {return control;} void SetControl(int n) {control = n;} int Count() {return count;} void SetCount(int n) {count = n;} }; /* // HandlerTaskRec */ class HandlerTaskRec { private: Packet *workIn, *deviceIn; public: HandlerTaskRec() {workIn = deviceIn = NoWork;} Packet *WorkIn() {return workIn;} void SetWorkIn(Packet *p) {workIn = p;} Packet *WorkInAdd(Packet *p) {return workIn = AddToList(workIn, p);} Packet *DeviceIn() {return deviceIn;} void SetDeviceIn(Packet *p) {deviceIn = p;} Packet *DeviceInAdd(Packet *p) {return deviceIn = AddToList(deviceIn, p);} }; /* // WorkerTaskRec */ class WorkerTaskRec { private: Identity destination; int count; public: WorkerTaskRec() {destination = HandlerA; count = 0;} int Count() {return count;} void SetCount(int n) {count = n;} Identity Destination() {return destination;} void SetDestination(Identity d) {destination = d;} }; cmucl-21a/src/benchmarks/soar/000077500000000000000000000000001260377556400164315ustar00rootroot00000000000000cmucl-21a/src/benchmarks/soar/default.soar000066400000000000000000000605011260377556400207450ustar00rootroot00000000000000(comment default soar version 4.0) (comment inter-lisp version go to lower case for other versions) (comment this production gathers all relevant preferences and makes them available to the decision procedure through the decide action. users should never create decide productions) (sp decision*gather-preferences decide (gc ^problem-space

^state ^operator ) (preference ^role ^value ^reference ^goal ^problem-space

^state ^operator ) --> (decide ^goal ^identifier ^role ^value ^reference )) (comment ****** common search-control productions ******) (comment all operator augmentations of the problem space have acceptable-preferences created for them) (sp default*make-all-operators-acceptable (gc ^problem-space

) (problem-space

^operator ) -(preference ^role operator ^value acceptable ^problem-space

) --> (preference ^role operator ^value acceptable ^problem-space

)) (comment if an operator has just been applied to a state - detected by using the preference created for that state - reject the operator for that state so it will not be reapplied in the future) (sp default*no-operator-retry (gc ^problem-space

^state ) (preference ^object ^role state ^value acceptable ^goal ^problem-space

^state ^operator { <> undecided <> nil }) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment if there is a reject-preference for the current state - make an acceptable-preference for the prior state so problem solving can backup) (sp default*backup-if-failed-state (gc ^problem-space

^state ) (preference ^role state ^value reject ^goal ^problem-space

) (preference ^role state ^value acceptable ^goal ^problem-space

^state { <> undecided <> nil } ^operator <> undecided) --> (preference ^role state ^value acceptable ^goal ^problem-space

^state )) (comment ****** default knowledge for impasses ****** ****** tie impasses ******) (comment if the problem space for handling the subgoal fails - signified by the choices none impasse below it - make a worst-preference for each tied object) (sp default*problem-space-tie (gc ^role goal ^choices none ^supergoal ) (gc ^role problem-space ^impasse tie ^supergoal ^item

) --> (preference

^role problem-space ^value worst ^goal )) (sp default*state-tie (gc ^role goal ^choices none ^supergoal ) (gc ^role state ^impasse tie ^supergoal ^item ) (gc ^problem-space

) --> (preference ^role state ^value worst ^goal ^problem-space

)) (sp default*operator-tie (gc ^role goal ^choices none ^supergoal ) (gc ^role operator ^impasse tie ^supergoal ^item ) (gc ^problem-space

^state ) --> (preference ^role operator ^value worst ^goal ^problem-space

^state )) (comment ****** conflict impasses ******) (comment if the problem space for handling the subgoal fails - signified by the choices none impasse below it - make a reject-preference for each conflicted object) (sp default*problem-space-conflict (gc ^role goal ^choices none ^supergoal ) (gc ^role problem-space ^impasse conflict ^supergoal ^item

) --> (preference

^role problem-space ^value reject ^goal )) (sp default*state-conflict (gc ^role goal ^choices none ^supergoal ) (gc ^role state ^impasse conflict ^supergoal ^item ) (gc ^problem-space

) --> (preference ^role state ^value reject ^goal ^problem-space

)) (sp default*operator-conflict (gc ^role goal ^choices none ^supergoal ) (gc ^role operator ^impasse conflict ^supergoal ^item ) (gc ^problem-space

^state ) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment ****** no-choice impasses ******) (comment if no problem spaces are available for the top goal - terminate the problem solving session with halt) (sp default*goal-no-choices (gc ^role goal ^choices none ^supergoal ) -(gc ^supergoal) --> (write1 (crlf) "No problem space can be selected for top goal.") (write1 (crlf) "Soar must terminate.") (halt)) (comment if no states are available for a problem space - and there is no problem space to find more - reject that problem space) (sp default*problem-space-no-choices (gc ^role goal ^choices none ^supergoal ) (gc ^role problem-space ^choices none ^supergoal ) (gc ^problem-space

) --> (preference

^role problem-space ^value reject ^goal )) (comment if no operators are available for a state - and there is no problem space to find more - reject that state) (sp default*state-no-choices (gc ^role goal ^choices none ^supergoal ) (gc ^role state ^choices none ^supergoal ) (gc ^problem-space

^state ) --> (preference ^role state ^value reject ^goal ^problem-space

)) (comment if no changes for an operator - and there is no problem space to find more - reject that operator) (sp default*operator-no-choices (gc ^role goal ^choices none ^supergoal ) (gc ^role operator ^impasse no-change ^supergoal ) (gc ^problem-space

^state ^operator ) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment ************** selection problem space ****************) (comment use the selection problem space for all choice multiple impasses - make it worst so that any other will dominate) (sp select*selection-space elaborate (gc ^choices multiple) --> (preference

^role problem-space ^value acceptable ^goal ) (preference

^role problem-space ^value worst ^goal ) (problem-space

^name selection)) (comment the state of the selection problem space is empty) (sp select*create-state (gc ^problem-space

^state undecided) (space

^name selection) --> (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided)) (comment ************** evaluate-object operator ****************) (comment create evaluate operator in selection problem space) (sp eval*select-evaluate (gc ^problem-space

^state ^supergoal ^item ) (problem-space

^name selection) --> (operator ^state ^name evaluate-object ^object ) (preference ^role operator ^value indifferent ^goal ^problem-space

^state ) (preference ^role operator ^value acceptable ^goal ^problem-space

^state )) (comment for parallel evaluation remove this comment if you want parallel evaluation of the alternatives. (sp eval*parallel-evaluate (gc ^problem-space

^state ^role operator ^supergoal ) (problem-space

^name selection ) (operator ^state ^object ) (operator ^state ^object { <> }) --> (preference ^role operator ^value parallel ^goal ^problem-space

^state ^reference ))) (comment create evaluation once the eval operator is selected) (sp eval*apply-evaluate (gc ^problem-space

^state ^operator ^role ^supergoal ) (problem-space

^name selection) (gc ^problem-space ^state ^desired ) (operator ^name evaluate-object ^object ) --> (state ^evaluation ) (evaluation ^object ^state ^operator ^desired ) (operator ^role ^evaluation ^desired ^supergoal ^superproblem-space ^superstate )) (comment reject evaluate-object after it finished in selection space) (sp eval*reject-evaluate-finished elaborate (gc ^problem-space

^state ^operator ) (problem-space

^name selection) (operator ^name evaluate-object ^evaluation ) (evaluation ^ << numeric-value symbolic-value >>) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment if two objects have equal evaluations they are indifferent) (sp eval*equal-eval-indifferent-preference (gc ^problem-space

^state ^role ^supergoal ) (problem-space

^name selection) (state ^evaluation ^evaluation { <> }) (gc ^problem-space ^state ^desired ) (evaluation ^object ^numeric-value ^desired ) (evaluation ^object ^numeric-value ^desired ) --> (preference ^role ^value indifferent ^reference ^goal ^problem-space ^state )) (comment generate operator preferences based on their evaluations and info as to whether higher or lower evaluations are better) (sp eval*prefer-higher-evaluation (gc ^problem-space

^state ^role ^supergoal ) (problem-space

^name selection) (gc ^problem-space ^state ^desired ) (state ^evaluation ^evaluation { <> }) (evaluation ^better higher) (evaluation ^object ^numeric-value ^desired ) (evaluation ^object ^numeric-value < ^desired ) --> (preference ^role ^value worse ^reference ^goal ^problem-space ^state )) (sp eval*prefer-lower-evaluation (gc ^problem-space

^state ^role ^supergoal ) (problem-space

^name selection) (gc ^problem-space ^state ^desired ) (state ^evaluation ^evaluation { <> }) (evaluation ^better lower) (evaluation ^object ^numeric-value ^desired ) (evaluation ^object ^numeric-value > ^desired ) --> (preference ^role operator ^value worse ^reference ^goal ^problem-space ^state )) (comment productions that fire in the evaluation subgoal) (comment copy down the desired and create the appropriate context - given the role of the object being evaluated) (sp eval*select-role-problem-space (gc ^problem-space undecided ^supergoal ^superoperator ) (gc ^operator ) (operator ^name evaluate-object ^role problem-space ^object

^desired ) --> (gc ^desired ) (preference

^role problem-space ^value acceptable ^goal )) (sp eval*select-role-state (gc ^problem-space undecided ^supergoal ^superoperator ) (gc ^operator ) (operator ^name evaluate-object ^role state ^object ^superproblem-space

^desired ) --> (gc ^desired ) (preference

^role problem-space ^value acceptable ^goal ) (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided) (preference ^role state ^value best ^goal ^problem-space

^state undecided)) (sp eval*select-role-operator (gc ^problem-space undecided ^supergoal ^superoperator ) (gc ^operator ) (operator ^name evaluate-object ^role operator ^object ^superproblem-space

^superstate ^desired ) --> (gc ^desired ) (preference

^role problem-space ^value acceptable ^goal ) (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided) (preference ^role operator ^value acceptable ^goal ^problem-space

^state )) (sp eval*reject-non-slot-operator (gc ^problem-space

^state ^supergoal ^superoperator ) (operator ^name evaluate-object ^role operator ^object ^superstate ) (preference { <> } ^role operator ^value acceptable ^goal ^problem-space

^state ) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment give symbol-value failure to an operator that has been rejected during evaluation and did not create a new state and reject the eval-operator) (sp eval*failure-if-reject-evaling-operator (gc ^problem-space

^state ^operator ^supergoal ^superoperator ) (gc ^problem-space ^state ) (operator ^name evaluate-object ^role operator ^object ^superstate ^evaluation ) (preference ^role operator ^value reject ^goal ^problem-space

^state ^operator ) -(preference ^role state ^value acceptable ^goal ^problem-space

^state ^operator ) --> (evaluation ^symbolic-value failure)) (comment give symbol-value failure to an operator that produces a state that gets rejected in the subgoal) (sp eval*failure-if-reject-state (gc ^problem-space

^state ^supergoal ^superoperator ) (gc ^problem-space ^state ) (operator ^name evaluate-object ^evaluation ) (preference ^role state ^value reject ^goal ^problem-space

) --> (evaluation ^symbolic-value failure)) (comment if an operator leads to success and it is being tried out in a subgoal to evaluate another operator - give that second operator a success evaluation also) (sp eval*pass-back-success elaborate (gc ^problem-space

^state ^operator ^supergoal ) (problem-space

^name selection) (operator ^name evaluate-object ^evaluation ^desired ) (evaluation ^symbolic-value success) (gc ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) --> (evaluation ^symbolic-value success)) (comment if an operator is evaluated to be lose or failure - create a worst-preference for it) (sp eval*failure-becomes-worst (gc ^problem-space

^state ^operator ^supergoal ) (problem-space

^name selection) (gc ^problem-space ^state ^desired ) (operator ^name evaluate-object ^evaluation ^desired ^role ^object ) (evaluation ^symbolic-value << lose failure >>) --> (preference ^role operator ^value worst ^goal ^problem-space ^state )) (comment if an operator is evaluated to be success - create a best-preference for it) (sp eval*success-becomes-best (gc ^problem-space

^state ^operator ^supergoal ) (problem-space

^name selection) (gc ^problem-space ^state ^desired ) (operator ^name evaluate-object ^evaluation ^desired ^object ^role ) (evaluation ^symbolic-value success) --> (preference ^role ^value best ^goal ^problem-space ^state )) (comment convert state augmentations into evaluations) (sp eval*state-to-evaluation-success (gc ^problem-space

^state ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) (state ^success ) --> (evaluation ^symbolic-value success)) (sp eval*state-to-evaluation-failure (gc ^problem-space

^state ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) (state ^failure ) --> (evaluation ^symbolic-value failure)) (sp eval*state-to-evaluation-win (gc ^problem-space

^state ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) (state ^win ) --> (evaluation ^symbolic-value win)) (sp eval*state-to-evaluation-draw (gc ^problem-space

^state ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) (state ^draw ) --> (evaluation ^symbolic-value draw)) (sp eval*state-to-evaluation-lose (gc ^problem-space

^state ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ) (state ^lose ) --> (evaluation ^symbolic-value lose)) (comment handle state augmentations dealing with goal termination for the top-level goal) (sp eval*detect-success (gc ^state ^name ^desired -^supergoal) (state ^success ) --> (write1 (crlf) "GOAL" "ACHIEVED") (halt)) (sp eval*detect-win (gc ^state ^name -^supergoal ^desired ) (state ^win ) --> (write1 (crlf) "GAME" "WON") (halt)) (sp eval*detect-failure (gc ^state ^name -^supergoal ^desired ) (state ^failure ) --> (preference ^role state ^value reject ^goal ^problem-space

)) (sp eval*detect-lose (gc ^state ^name -^supergoal ^desired ) (state ^lose ) --> (write1 (crlf) "GAME" "LOST") (halt)) (comment two player games - win side oside lose) (sp eval*move-side-to-eval (gc ^state ^superoperator ) (state ^oside ^ << lose win >>) (operator ^name evaluate-object ^evaluation ) --> (evaluation ^side )) (sp eval*winning-values (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (gc ^problem-space ^state ) (state ^side ) (operator ^name evaluate-object ^evaluation ^object ^role ) (evaluation ^symbolic-value win ^side ) --> (preference ^role ^value best ^goal ^problem-space ^state )) (sp eval*winning-values2 (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (gc ^problem-space ^state ) (state ^oside ) (operator ^name evaluate-object ^evaluation ^object ^role ) (evaluation ^symbolic-value lose ^side ) --> (preference ^role ^value best ^goal ^problem-space ^state )) (sp eval*draw-values (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (gc ^problem-space ^state ) (operator ^name evaluate-object ^evaluation ^object ^role ) (evaluation ^symbolic-value draw) --> (preference ^role ^value indifferent ^goal ^problem-space ^state )) (sp eval*losing-values (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (gc ^problem-space ^state ) (state ^oside ) (operator ^name evaluate-object ^evaluation ^object ^role ) (evaluation ^symbolic-value win ^side ) --> (preference ^role ^value worst ^goal ^problem-space ^state )) (sp eval*losing-values2 (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (gc ^problem-space ^state ) (state ^side ) (operator ^name evaluate-object ^evaluation ^object ^role ) (evaluation ^symbolic-value lose ^side ) --> (preference ^role ^value worst ^goal ^problem-space ^state )) (sp eval*pass-back-win (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (operator ^name evaluate-object ^evaluation ^desired ) (evaluation ^symbolic-value win ^side ) (gc ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ^superstate ) (state ^oside ) --> (evaluation ^symbolic-value win ^side )) (sp eval*pass-back-win2 (gc ^problem-space

^state ^supergoal ^operator ) (problem-space

^name selection) (operator ^name evaluate-object ^evaluation ^desired ) (evaluation ^symbolic-value lose ^side ) (gc ^superoperator ) (operator ^name evaluate-object ^evaluation ^desired ^superstate ) (state ^side ) --> (evaluation ^symbolic-value win ^side )) (comment **************** operator subgoaling **************** there are two ways to do operator subgoal just pass down most recent operator - or pass down all of them this implementation passes down just the super operator as the desired - uncomment opsub*go-for-it2 if you want all supergoals to be included) (comment make the super-problem space the default when there is a no-change for the operator) (sp opsub*try-operator-subgoaling elaborate (gc ^impasse no-change ^role operator ^problem-space undecided ^supergoal ) (gc ^problem-space ) --> (preference ^goal ^role problem-space ^value acceptable) (preference ^goal ^role problem-space ^value worst)) (comment if the superproblem-space is selected as the current problem space then operator subgoaling is being used so select the superstate - the superoperator becomes the desired) (sp opsub*go-for-it elaborate (gc ^problem-space

^state undecided ^impasse no-change ^role operator ^supergoal ) (gc ^problem-space

^state ^operator ) --> (gc ^name operator-subgoal ^desired ) (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided)) (comment pass down all super operator subgoals as well (sp opsub*go-for-it2 elaborate (gc ^problem-space

^state undecided ^impasse no-change ^role operator ^supergoal ) (gc ^problem-space

^state ^desired ) --> (gc ^desired )) ) (comment don't select the operator for the initial state that we are subgoaling on) (sp opsub*reject-opsub*operator (gc ^problem-space

^state ^desired ) (op-info ^identifier ) (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment select superoperator for all new states) (sp opsub*select-opsub*operator elaborate (gc ^problem-space

^state ^desired ) (op-info ^identifier ) --> (preference ^role operator ^value acceptable ^goal ^problem-space

^state ) (preference ^role operator ^value best ^goal ^problem-space

^state )) (comment if superoperator applied to a state then success we make a preference for the state it created) (sp opsub*detect-direct-opsub-success elaborate (gc ^problem-space

^state ^operator ^supergoal ^name operator-subgoal) (gc ^problem-space

^state ^operator ) (preference ^role state ^value acceptable ^goal ^problem-space

^state ^operator ) --> (preference ^role state ^value acceptable ^goal ^problem-space

^state ^operator )) (comment if there is an evaluation subgoal within an operator subgoal and the operator being subgoaled on is applied - success) (sp opsub*detect-indirect-opsub-success elaborate (gc ^name operator-subgoal ^supergoal ) (gc ^problem-space

^state ^operator ) (gc ^problem-space

^state ^operator ^desired ^superoperator ) (operator ^name evaluate-object) (preference ^role state ^value acceptable ^goal ^problem-space

^state ^operator ) --> (state ^success )) (comment if the operator being subgoaled on is the current operator and a no-change subgoal is created for it then reject it in the subgoal) (sp opsub*reject-double-op-sub (gc ^name operator-subgoal ^desired ) (gc { <> } ^name operator-subgoal) (gc ^supergoal ) (gc ^problem-space

^state ^operator ) -(gc ^supergoal ) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) nil cmucl-21a/src/benchmarks/soar/eight.soar000066400000000000000000000217161260377556400204260ustar00rootroot00000000000000(comment eight puzzle for soar 35) (comment this is the eight puzzle problem) (comment state structure each state contains nine bindings the bindings connect together a cell - one of the nine positions on the board - and a tile - one of the movable pieces the cells have pointers ^cell to each of their adjacent cells the state also has a pointer to the blank-cell and the cell that the last moved tile is in this improve efficiency and simplify computations that depend on the previous operator) (comment each operator contains a pointer to the cell with the blank and the cell with the tile to be moved) (multi-attributes '((state binding 5) (desired binding 5) (operator blank 3) (operator cell 2) (cell cell 4))) (trace-attributes '((operator tile-cell))) (comment name the first subgoal eight-puzzle and create the problem space and operators) (sp eight*start (gc ^problem-space undecided - ^supergoal) --> (gc ^name solve-eight-puzzle ^impasse ^desired ) (problem-space

^name eight-puzzle) (preference

^role problem-space ^value acceptable ^goal )) (comment define the initial state and the impasse state each state is a set of bindings each binding points to a cell and a tile each cell points to its neighboring cells) (sp eight*initial-desired-states (gc ^problem-space

^state undecided ^name solve-eight-puzzle ^desired ) (space

^name eight-puzzle) --> (preference ^role state ^value acceptable ^goal ^problem-space

^state undecided) (tile ^name 0) (tile ^name 1) (tile ^name 2) (tile ^name 3) (tile ^name 4) (tile ^name 5) (tile ^name 6) (tile ^name 7) (tile ^name 8) (binding ^cell c11 ^tile ) (binding ^cell c12 ^tile ) (binding ^cell c13 ^tile ) (binding ^cell c21 ^tile ) (binding ^cell c22 ^tile ) (binding ^cell c23 ^tile ) (binding ^cell c31 ^tile ) (binding ^cell c32 ^tile ) (binding ^cell c33 ^tile ) (state ^binding ^blank-cell c23) (cell c11 ^cell c12 ^cell c21) (cell c12 ^cell c11 ^cell c13 ^cell c22) (cell c13 ^cell c12 ^cell c23) (cell c21 ^cell c11 ^cell c31 ^cell c22) (cell c22 ^cell c21 ^cell c12 ^cell c23 ^cell c32) (cell c23 ^cell c22 ^cell c33 ^cell c13) (cell c31 ^cell c32 ^cell c21) (cell c32 ^cell c31 ^cell c22 ^cell c33) (cell c33 ^cell c32 ^cell c23) (binding ^cell c11 ^tile ) (binding ^cell c12 ^tile ) (binding ^cell c13 ^tile ) (binding ^cell c21 ^tile ) (binding ^cell c22 ^tile ) (binding ^cell c23 ^tile ) (binding ^cell c31 ^tile ) (binding ^cell c32 ^tile ) (binding ^cell c33 ^tile ) (desired ^binding ) (evaluation ^better higher) ) (comment create an operator if it will apply) (sp eight*acceptable (gc ^problem-space

^state ) (problem-space

^name eight-puzzle) (state ^blank-cell ) (cell ^cell ) -(op-info ^attribute state ^value ) --> (operator ^name move-tile ^state ^tile-cell ^blank-cell ) (preference ^role operator ^value acceptable ^goal ^problem-space

^state )) (comment reject the operator that was applied to create this state) (sp eight*reject-undo (gc ^problem-space

^state ) (problem-space

^name eight-puzzle) (state ^tile-cell ) (preference ^role operator ^value acceptable ^problem-space

^state ) (operator ^tile-cell ) --> (preference ^role operator ^value reject ^goal ^problem-space

^state )) (comment apply operator to state and copy unchanged bindings new state) (comment swap blank binding and one specified by operator) (sp eight*apply-move-tile (gc ^problem-space

^state ^operator ) (problem-space

^name eight-puzzle) (state ^binding ^blank-cell ) (binding ^tile ^cell ) (binding ^tile ^cell ) (operator ^tile-cell ^blank-cell ^name move-tile) --> (preference ^role state ^value acceptable ^goal ^problem-space

^state ^operator ) (state ^blank-cell ^tile-cell ^binding ^binding ) (binding ^tile ^cell ) (binding ^tile ^cell ) ) (comment copy pointers to all untouched bindings) (sp eight*copy-unchanged (gc ^problem-space

^state ^operator ) (problem-space

^name eight-puzzle) (preference ^role state ^value acceptable ^problem-space

^state { <> nil } ^operator { <> nil }) (state ^binding ) (binding ^cell ) (state -^tile-cell -^blank-cell ) --> (state ^binding )) (comment detect success) (sp eight*detect-goal (gc ^problem-space

^state ^desired ) (space

^name eight-puzzle) (state ^binding ) (binding ^cell c11 ^tile ) (binding ^cell c12 ^tile ) (binding ^cell c13 ^tile ) (binding ^cell c21 ^tile ) (binding ^cell c22 ^tile ) (binding ^cell c23 ^tile ) (binding ^cell c31 ^tile ) (binding ^cell c32 ^tile ) (binding ^cell c33 ^tile ) (desired ^binding ) (binding ^cell c11 ^tile ) (binding ^cell c12 ^tile ) (binding ^cell c13 ^tile ) (binding ^cell c21 ^tile ) (binding ^cell c22 ^tile ) (binding ^cell c23 ^tile ) (binding ^cell c31 ^tile ) (binding ^cell c32 ^tile ) (binding ^cell c33 ^tile ) --> (state ^success )) (comment monitor new states) (sp eight*monitor (gc ^problem-space

^state ^operator ) (problem-space

^name eight-puzzle) (preference ^role state ^value acceptable ^problem-space

^state ^operator ) (operator ^tile-cell ) (state ^binding ) (binding ^cell c11 ^tile ) (binding ^cell c12 ^tile ) (binding ^cell c13 ^tile ) (binding ^cell c21 ^tile ) (binding ^cell c22 ^tile ) (binding ^cell c23 ^tile ) (binding ^cell c31 ^tile ) (binding ^cell c32 ^tile ) (binding ^cell c33 ^tile ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) (tile ^name ) --> (write2 (crlf) (crlf) "(" ") --> " (crlf)) (write1 " -------------" (crlf)) (write1 " |" "|" "|" "|" (crlf)) (write1 " |---|---|---|" (crlf)) (write1 " |" "|" "|" "|" (crlf)) (write1 " |---|---|---|" (crlf)) (write1 " |" "|" "|" "|" (crlf)) (write1 " -------------" (crlf))) (comment compute evaluation function based on changes by operators) (comment 1 point for moving binding into its impasse location) (sp eight*eval-state-plus-one (gc ^problem-space

^state { <> } ^superoperator ) (problem-space

^name eight-puzzle) (operator ^name evaluate-object ^evaluation ^superstate ^desired ) (state ^tile-cell ^binding ) (binding ^cell ^tile ) (desired ^binding ) (binding ^cell ^tile ) --> (evaluation ^numeric-value 1)) (comment 0 points for not moving tile in or out of its impasse cell) (sp eight*eval-state-zero (gc ^problem-space

^state { <> } ^superoperator ) (space

^name eight-puzzle) (operator ^name evaluate-object ^evaluation ^desired ^superstate ) (state ^tile-cell ^blank-cell ^binding ) (binding ^cell ^tile ) (binding ^tile ) (binding ^tile ) (desired ^binding ) (binding ^cell ^tile { <> }) (binding ^cell ^tile { <> }) --> (evaluation ^numeric-value 0)) (comment -1 points for moving tile out of its impasse cell) (sp eight*eval-state-minus-one (gc ^problem-space

^state { <> } ^superoperator ) (space

^name eight-puzzle) (operator ^name evaluate-object ^evaluation ^desired ^superstate ) (state ^tile-cell ^binding ^blank-cell ) (binding ^cell ^tile ) (desired ^binding ) (binding ^cell ^tile ) --> (evaluation ^numeric-value -1)) nil cmucl-21a/src/benchmarks/soar/readme.txt000066400000000000000000000003351260377556400204300ustar00rootroot00000000000000To run soar: (load "soar.fasl") (load "default.soar") (load "eight.soar") (d) Optionally before calling D, you can call WATCH with -1 to turn off tracing information. This is desirable for timing situation. cmucl-21a/src/benchmarks/soar/soar.lisp000066400000000000000000007547301260377556400203060ustar00rootroot00000000000000;;; -*- Mode: LISP; Package: User -*- #+declare-unsafe (proclaim '(optimize (speed 3) (safety 0))) (proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars* *curcond* *subnum* *last-node* *last-branch* *first-node* *sendtocall* *flag-part* *alpha-flag-part* *data-part* *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt* *current-token* *record-array* *result-array* *max-cs* *total-cs* *limit-cs* *cr-temp* *side* *conflict-set* *halt-flag* *phase* *critical* *cycle-count* *total-token* *max-token* *refracts* *limit-token* *total-wm* *current-wm* *max-wm* *action-count* *wmpart-list* *wm* *data-matched* *p-name* *variable-memory* *ce-variable-memory* *max-index* *next-index* *size-result-array* *rest* *build-trace* *last* *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* *write-file* *record-index* *max-record-index* *old-wm* *record* *filters* *break-flag* *strategy* *remaining-cycles* *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* *ce-count* *brkpts* *class-list* *buckets* *action-type*)) (proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127* )) (defmacro soarputprop (n v a) `(setf (get ,n ,a) ,v)) (defmacro soarassq (item alist) `(assoc ,item ,alist :test #'eq)) ; getvector and putvector are fast routines for using ONE-DIMENSIONAL ; arrays. these routines do no checking; they assume ; 1. the array is a vector with 0 being the index of the first ; element ; 2. the vector holds arbitrary list values (defmacro putvector (array index value) `(setf (svref ,array ,index) ,value)) (defmacro getvector (array index) `(svref ,array ,index)) (shadow 'remove (find-package 'user)) (defmacro remove (&body z) `(ops-remove ',z)) (shadow 'write (find-package 'user)) (defmacro write (&body z) `(ops-write ',z)) (defmacro princq (ob &optional st) (cond ((eq st nil) `(princ ,ob)) (t `(princ ,ob ,st)))) (defmacro literal (&body z) `(ops-literal ',z)) (defmacro literalize (&body z) `(ops-literalize ',z)) (defmacro vector-attribute (&body l) `(ops-vector-attribute ',l)) (defmacro p (&body z) `(ops-p ',z)) (defmacro wm (&body a) `(ops-wm ',a)) (defmacro make (&body z) `(ops-make ',z)) (defmacro modify (&body z) `(ops-modify ',z)) (defmacro bind (&body z) `(ops-bind ',z)) (defmacro cbind (&body z) `(ops-cbind ',z)) (defmacro call1 (&body z) `(ops-call1 ',z)) (defmacro build (&body z) `(ops-build ',z)) (defmacro openfile (&body z) `(ops-openfile ',z)) (defmacro closefile (&body z) `(ops-closefile ',z)) (defmacro default (&body z) `(ops-default ',z)) (defmacro accept (&body z) `(ops-accept ',z)) (defmacro acceptline (&body z) `(ops-acceptline ',z)) (defmacro substr (&body l) `(ops-substr ',l)) (defmacro compute (&body z) `(ops-compute ',z)) (defmacro arith (&body z) `(ops-arith ',z)) (defmacro litval (&body z) `(ops-litval ',z)) (defmacro rjust (&body z) `(ops-rjust ',z)) (defmacro crlf (&body z) `(ops-crlf ',z)) (defmacro tabto (&body z) `(ops-tabto ',z)) (defmacro ppwm (&body avlist) `(ops-ppwm ',avlist)) (defmacro pm (&body z) `(ops-pm ',z)) (defmacro matches (&body rule-list) `(ops-matches ',rule-list)) (defmacro excise (&body z) `(ops-excise ',z)) (defmacro run (&body z) `(ops-run ',z)) (defmacro strategy (&body z) `(ops-strategy ',z)) (defmacro cs (&body z) `(ops-cs ',z)) (defmacro watch (&body z) `(ops-watch ',z)) (defmacro external (&body z) `(ops-external ',z)) (defmacro pbreak (&body z) `(ops-pbreak ',z)) (defmacro == (x y) `(equal ,x ,y)) (defmacro =alg (a b) `(equalp ,a ,b)) (defun ce-gelm (x k) (declare (optimize speed)) (prog nil loop (and (== k 1.) (return (car x))) (setq k (1- k)) (setq x (cdr x)) (go loop))) (defun gelm (x k) (declare (optimize speed)) (prog (ce sub) (setq ce (truncate k 10000.)) ;use multiple-value-setq??? (setq sub (- k (* ce 10000.))) ;@@@ ^ celoop (and (eq ce 0.) (go ph2)) (setq x (cdr x)) (and (eq ce 1.) (go ph2)) (setq x (cdr x)) (and (eq ce 2.) (go ph2)) (setq x (cdr x)) (and (eq ce 3.) (go ph2)) (setq x (cdr x)) (and (eq ce 4.) (go ph2)) (setq ce (- ce 4.)) (go celoop) ph2 (setq x (car x)) subloop (and (eq sub 0.) (go finis)) (setq x (cdr x)) (and (eq sub 1.) (go finis)) (setq x (cdr x)) (and (eq sub 2.) (go finis)) (setq x (cdr x)) (and (eq sub 3.) (go finis)) (setq x (cdr x)) (and (eq sub 4.) (go finis)) (setq x (cdr x)) (and (eq sub 5.) (go finis)) (setq x (cdr x)) (and (eq sub 6.) (go finis)) (setq x (cdr x)) (and (eq sub 7.) (go finis)) (setq x (cdr x)) (and (eq sub 8.) (go finis)) (setq sub (- sub 8.)) (go subloop) finis (return (car x))) ) ;;; Utility functions ;;; intersect two lists using eq for the equality test (defun interq (x y) (cond ((atom x) nil) ((member (car x) y) (cons (car x) (interq (cdr x) y))) (t (interq (cdr x) y)))) (eval-when (compile load eval) (set-macro-character #\{ #'(lambda (s c) (declare (ignore s c)) '\{)) ;5/5/83 (set-macro-character #\} #'(lambda (s c) (declare (ignore s c)) '\})) ;5/5/83 (set-macro-character #\^ #'(lambda (s c) (declare (ignore s c)) '\^)) ;5/5/83 ) (defun %warn (what where) (prog nil (terpri) (princ '?) (and *p-name* (princ *p-name*)) (princ '"..") (princ where) (princ '"..") (princ what) (return where))) (defun %error (what where) (%warn what where) (throw '!error! '!error!)) (defun top-levels-eq (la lb) (prog nil lx (cond ((eq la lb) (return t)) ((null la) (return nil)) ((null lb) (return nil)) ((not (eq (car la) (car lb))) (return nil))) (setq la (cdr la)) (setq lb (cdr lb)) (go lx))) ;;; LITERAL and LITERALIZE (defun ops-literal (z) (prog (atm val old) top (and (atom z) (return 'bound)) (or (eq (cadr z) '=) (return (%warn '|wrong format| z))) (setq atm (car z)) (setq val (caddr z)) (setq z (cdddr z)) (cond ((not (numberp val)) (%warn '|can bind only to numbers| val)) ((or (not (symbolp atm)) (variablep atm)) (%warn '|can bind only constant atoms| atm)) ((and (setq old (literal-binding-of atm)) (not (equal old val))) (%warn '|attempt to rebind attribute| atm)) (t (soarputprop atm val 'ops-bind)) (go top)))) (defun ops-literalize (l) (prog (class-name atts) (setq class-name (car l)) (cond ((have-compiled-production) (%warn '|literalize called after p| class-name) (return nil)) ((get class-name 'att-list) (%warn '|attempt to redefine class| class-name) (return nil))) (setq *class-list* (cons class-name *class-list*)) (setq atts (remove-duplicates (cdr l))) (test-attribute-names atts) (mark-conflicts atts atts) (soarputprop class-name atts 'att-list))) (defun ops-vector-attribute (l) (cond ((have-compiled-production) (%warn '|vector-attribute called after p| l)) (t (test-attribute-names l) (mapc (function vector-attribute2) l)))) (defun vector-attribute2 (att) (soarputprop att t 'vector-attribute)) (defun is-vector-attribute (att) (get att 'vector-attribute)) (defun test-attribute-names (l) (mapc (function test-attribute-names2) l)) (defun test-attribute-names2 (atm) (cond ((or (not (symbolp atm)) (variablep atm)) (%warn '|can bind only constant atoms| atm)))) (defun have-compiled-production nil (not (zerop *pcount*))) (defun put-ppdat (class) (prog (al att ppdat) (setq ppdat nil) (setq al (get class 'att-list)) top (cond ((not (atom al)) (setq att (car al)) (setq al (cdr al)) (setq ppdat (cons (cons (literal-binding-of att) att) ppdat)) (go top))) (soarputprop class ppdat 'ppdat))) ; note-user-assigns and note-user-vector-assigns are needed only when ; literal and literalize are both used in a program. They make sure that ; the assignments that are made explicitly with literal do not cause problems ; for the literalized classes. (defun note-user-assigns (class) (mapc (function note-user-assigns2) (get class 'att-list))) (defun note-user-assigns2 (att) (prog (num conf buck clash) (setq num (literal-binding-of att)) (and (null num) (return nil)) (setq conf (get att 'conflicts)) (setq buck (store-binding att num)) (setq clash (find-common-atom buck conf)) (and clash (%warn '|attributes in a class assigned the same number| (cons att clash))) (return nil))) (defun note-user-vector-assigns (att given needed) (and (> needed given) (%warn '|vector attribute assigned too small a value in literal| att))) (defun assign-scalars (class) (mapc (function assign-scalars2) (get class 'att-list))) (defun assign-scalars2 (att) (prog (tlist num bucket conf) (and (literal-binding-of att) (return nil)) (and (is-vector-attribute att) (return nil)) (setq tlist (buckets)) (setq conf (get att 'conflicts)) top (cond ((atom tlist) (%warn '|could not generate a binding| att) (store-binding att -1.) (return nil))) (setq num (caar tlist)) (setq bucket (cdar tlist)) (setq tlist (cdr tlist)) (cond ((disjoint bucket conf) (store-binding att num)) (t (go top))))) (defun assign-vectors (class) (mapc (function assign-vectors2) (get class 'att-list))) (defun assign-vectors2 (att) (prog (big conf new old need) (and (not (is-vector-attribute att)) (return nil)) (setq big 1.) (setq conf (get att 'conflicts)) top (cond ((not (atom conf)) (setq new (car conf)) (setq conf (cdr conf)) (cond ((is-vector-attribute new) (%warn '|class has two vector attributes| (list att new))) (t (setq big (max (literal-binding-of new) big)))) (go top))) (setq need (1+ big)) ;"plus" changed to "+" by gdw (setq old (literal-binding-of att)) (cond (old (note-user-vector-assigns att old need)) (t (store-binding att need))) (return nil))) (defun disjoint (la lb) (not (find-common-atom la lb))) (defun find-common-atom (la lb) (prog nil top (cond ((null la) (return nil)) ((member (car la) lb) (return (car la))) (t (setq la (cdr la)) (go top))))) (defun mark-conflicts (rem all) (cond ((not (null rem)) (mark-conflicts2 (car rem) all) (mark-conflicts (cdr rem) all)))) (defun mark-conflicts2 (atm lst) (prog (l) (setq l lst) top (and (atom l) (return nil)) (conflict atm (car l)) (setq l (cdr l)) (go top))) (defun conflict (a b) (prog (old) (setq old (get a 'conflicts)) (and (not (eq a b)) (not (member b old)) (soarputprop a (cons b old) 'conflicts)))) (defun literal-binding-of (name) (get name 'ops-bind)) (defun store-binding (name lit) (soarputprop name lit 'ops-bind) (add-bucket name lit)) (defun add-bucket (name num) (prog (buc) (setq buc (assoc num (buckets))) (and (not (member name buc)) (rplacd buc (cons name (cdr buc)))) (return buc))) (defun buckets nil (and (atom *buckets*) (setq *buckets* (make-nums *buckets*))) *buckets*) (defmacro ncons (x) `(cons ,x nil)) (defun make-nums (k) (prog (nums) (setq nums nil) l (and (< k 2.) (return nums)) (setq nums (cons (ncons k) nums)) (setq k (1- k)) (go l))) (defun erase-literal-info (class) (mapc (function erase-literal-info2) (get class 'att-list)) (remprop class 'att-list)) (defun erase-literal-info2 (att) (remprop att 'conflicts)) ;;; LHS Compiler (defun peek-lex nil (car *matrix*)) (defun lex nil (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) (defun end-of-p nil (atom *matrix*)) (defun rest-of-p nil *matrix*) (defun prepare-lex (prod) (setq *matrix* prod)) (defun peek-sublex nil (car *curcond*)) (defun sublex nil (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) (defun end-of-ce nil (atom *curcond*)) (defun rest-of-ce nil *curcond*) (defun prepare-sublex (ce) (setq *curcond* ce)) (defun make-bottom-node nil (setq *first-node* (list '&bus nil))) (defun rating-part (pnode) (cadr pnode)) (defun var-part (pnode) (car (cdddr pnode))) (defun ce-var-part (pnode) (cadr (cdddr pnode))) (defun rhs-part (pnode) (caddr (cdddr pnode))) (defun kill-node (node) (prog nil top (and (atom node) (return nil)) (rplaca node '&old) (setq node (cdr node)) (go top))) (defun cmp-negce nil (lex) (cmp-ce)) (defun cmp-posce nil (setq *ce-count* (1+ *ce-count*)) (cond ((eq (peek-lex) '\{) (cmp-ce+cevar)) (t (cmp-ce)))) (defun cmp-ce+cevar nil (prog (z) (lex) (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce)) (t (cmp-ce) (cmp-cevar))) (setq z (lex)) (or (eq z '\}) (%error '|missing '}'| z)))) (defun new-subnum (k) (or (numberp k) (%error '|tab must be a number| k)) (setq *subnum* (fix k))) (defun incr-subnum nil (setq *subnum* (1+ *subnum*))) (defun cmp-element nil (and (eq (peek-sublex) '^) (cmp-tab)) (cond ((eq (peek-sublex) '\{) (cmp-product)) (t (cmp-atomic-or-any)))) (defun cmp-atomic-or-any nil (cond ((eq (peek-sublex) '<<) (cmp-any)) (t (cmp-atomic)))) (defun cmp-any nil (prog (a z) (sublex) (setq z nil) la (cond ((end-of-ce) (%error '|missing '>>'| a))) (setq a (sublex)) (cond ((not (eq '>> a)) (setq z (cons a z)) (go la))) (link-new-node (list '&any nil (current-field) z)))) (defun $litbind (x) (prog (r) (cond ((and (symbolp x) (setq r (literal-binding-of x))) (return r)) (t (return x))))) (defun get-bind (x) (prog (r) (cond ((and (symbolp x) (setq r (literal-binding-of x))) (return r)) (t (return nil))))) (defun cmp-atomic nil (prog (test x) (setq x (peek-sublex)) (cond ((eq x '= ) (setq test 'eq) (sublex)) ((eq x '<>) (setq test 'ne) (sublex)) ((eq x '<) (setq test 'lt) (sublex)) ((eq x '<=) (setq test 'le) (sublex)) ((eq x '>) (setq test 'gt) (sublex)) ((eq x '>=) (setq test 'ge) (sublex)) ((eq x '<=>) (setq test 'xx) (sublex)) (t (setq test 'eq))) (cmp-symbol test))) (defun cmp-product nil (prog (save) (setq save (rest-of-ce)) (sublex) la (cond ((end-of-ce) (cond ((member '\} save :test #'equal) (%error '|wrong contex for '}'| save)) (t (%error '|missing '}'| save)))) ((eq (peek-sublex) '\}) (sublex) (return nil))) (cmp-atomic-or-any) (go la))) (defun symbol-print-name (x) (symbol-name x)) (defun cmp-symbol (test) (prog (flag) (setq flag t) (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil))) (cond ((and flag (variablep (peek-sublex))) (cmp-var test)) ((numberp (peek-sublex)) (cmp-number test)) ((symbolp (peek-sublex)) (cmp-constant test)) (t (%error '|unrecognized symbol| (sublex)))))) (defun cmp-constant (test) (or (member test '(eq ne xx)) (%error '|non-numeric constant after numeric predicate| (sublex))) (link-new-node (list (intern (concatenate 'string (symbol-print-name 't) (symbol-print-name test) (symbol-print-name 'a))) nil (current-field) (sublex)))) (defun cmp-number (test) (link-new-node (list (intern (concatenate 'string (symbol-print-name 't) (symbol-print-name test) (symbol-print-name 'n))) nil ;outs -- nodelist to traverse (current-field) ;register (sublex)))) ;constant ; %%% things to change to convert set of *cN* to *c* array: ; %%% current-field field-name *subnum* eval-nodelist ?? wm-hash ; %%% send-to, &bus (defun current-field nil (field-name *subnum*)) (defun field-name (num) (cond ((= num 1.) '*c1*) ((= num 2.) '*c2*) ((= num 3.) '*c3*) ((= num 4.) '*c4*) ((= num 5.) '*c5*) ((= num 6.) '*c6*) ((= num 7.) '*c7*) ((= num 8.) '*c8*) ((= num 9.) '*c9*) ((= num 10.) '*c10*) ((= num 11.) '*c11*) ((= num 12.) '*c12*) ((= num 13.) '*c13*) ((= num 14.) '*c14*) ((= num 15.) '*c15*) ((= num 16.) '*c16*) (t (%error '|condition is too long| (rest-of-ce))))) ;;; Compiling variables ; ; ; ; *cur-vars* are the variables in the condition element currently ; being compiled. *vars* are the variables in the earlier condition ; elements. *ce-vars* are the condition element variables. note ; that the interpreter will not confuse condition element and regular ; variables even if they have the same name. ; ; *cur-vars* is a list of triples: (name predicate subelement-number) ; eg: ( ( eq 3) ; ( ne 1) ; . . . ) ; ; *vars* is a list of triples: (name ce-number subelement-number) ; eg: ( ( 3 3) ; ( 1 1) ; . . . ) ; ; *ce-vars* is a list of pairs: (name ce-number) ; eg: ( (ce1 1) ; ( 3) ; . . . ) (defun var-dope (var) (soarassq var *vars*)) (defun ce-var-dope (var) (soarassq var *ce-vars*)) (defun cmp-new-var (name test) (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) (defun cmp-old-eq-var (test old) ; jgk inserted concatenate form (link-new-node (list (intern (concatenate 'string (symbol-print-name 't) (symbol-print-name test) (symbol-print-name 's))) nil (current-field) (field-name (caddr old))))) ;@@@ added defunb of delq ;(defun delq (i l) ; (delete i l :test #'eq)) ; ; Spdelete "special delete" is a function which deletes every occurence ; of element from list. This function was defined because common lisp's ; delete function only deletes top level elements from a list, not lists ; from lists. ; (defun spdelete (element list) (cond ((null list) nil) ((equal element (car list)) (spdelete element (cdr list))) (t (cons (car list) (spdelete element (cdr list)))))) (defun cmp-new-eq-var (name old) ;jgk inserted concatenate form (prog (pred next) (setq *cur-vars* (delq old *cur-vars*)) (setq next (soarassq name *cur-vars*)) (cond (next (cmp-new-eq-var name next)) (t (cmp-new-var name 'eq))) (setq pred (cadr old)) (link-new-node (list (intern (concatenate 'string (symbol-print-name 't) (symbol-print-name pred) (symbol-print-name 's))) nil (field-name (caddr old)) (current-field))))) (defun cmp-cevar nil (prog (name old) (setq name (lex)) (setq old (soarassq name *ce-vars*)) (and old (%error '|condition element variable used twice| name)) (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) (defun cmp-not nil (cmp-beta '¬)) (defun cmp-nobeta nil (cmp-beta nil)) (defun cmp-and nil (cmp-beta '&and)) (defun cmp-beta (kind) (prog (tlist vdope vname #|vpred vpos|# old) (setq tlist nil) la (and (atom *cur-vars*) (go lb)) (setq vdope (car *cur-vars*)) (setq *cur-vars* (cdr *cur-vars*)) (setq vname (car vdope)) ;; (setq vpred (cadr vdope)) Dario - commented out (unused) ;; (setq vpos (caddr vdope)) (setq old (soarassq vname *vars*)) (cond (old (setq tlist (add-test tlist vdope old))) ((not (eq kind '¬)) (promote-var vdope))) (go la) lb (and kind (build-beta kind tlist)) (or (eq kind '¬) (fudge)) (setq *last-branch* *last-node*))) (defun add-test (list new old) ; jgk inserted concatenate form (prog (ttype lloc rloc) (setq *feature-count* (1+ *feature-count*)) (setq ttype (intern (concatenate 'string (symbol-print-name 't) (symbol-print-name (cadr new)) (symbol-print-name 'b)))) (setq rloc (encode-singleton (caddr new))) (setq lloc (encode-pair (cadr old) (caddr old))) (return (cons ttype (cons lloc (cons rloc list)))))) ; the following two functions encode indices so that gelm can ; decode them as fast as possible ;; %%% change to use clisp hash fns ?? (defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) ;"plus" changed to "+" by gdw (defun encode-singleton (a) (1- a)) (defun fudge nil (mapc (function fudge*) *vars*) (mapc (function fudge*) *ce-vars*)) (defun fudge* (z) (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) (defun build-beta (type tests) (prog (rpred lpred lnode lef) (link-new-node (list '&mem nil nil (protomem))) (setq rpred *last-node*) (cond ((eq type '&and) (setq lnode (list '&mem nil nil (protomem)))) (t (setq lnode (list '&two nil nil)))) (setq lpred (link-to-branch lnode)) (cond ((eq type '&and) (setq lef lpred)) (t (setq lef (protomem)))) (link-new-beta-node (list type nil lef rpred tests)))) (defun protomem nil (list nil)) (defun memory-part (mem-node) (car (cadddr mem-node))) (defun encode-dope nil (prog (r all z k) (setq r nil) (setq all *vars*) la (and (atom all) (return r)) (setq z (car all)) (setq all (cdr all)) (setq k (encode-pair (cadr z) (caddr z))) (setq r (cons (car z) (cons k r))) (go la))) (defun encode-ce-dope nil (prog (r all z k) (setq r nil) (setq all *ce-vars*) la (and (atom all) (return r)) (setq z (car all)) (setq all (cdr all)) (setq k (cadr z)) (setq r (cons (car z) (cons k r))) (go la))) ;;; Linking the nodes (defun link-new-node (r) (cond ((not (member (car r) '(&p &mem &two &and ¬) :test #'equal)) (setq *feature-count* (1+ *feature-count*)))) (setq *virtual-cnt* (1+ *virtual-cnt*)) (setq *last-node* (link-left *last-node* r))) (defun link-to-branch (r) (setq *virtual-cnt* (1+ *virtual-cnt*)) (setq *last-branch* (link-left *last-branch* r))) (defun link-new-beta-node (r) (setq *virtual-cnt* (1+ *virtual-cnt*)) (setq *last-node* (link-both *last-branch* *last-node* r)) (setq *last-branch* *last-node*)) (defun link-left (pred succ) (prog (a r) (setq a (left-outs pred)) (setq r (find-equiv-node succ a)) (and r (return r)) (setq *real-cnt* (1+ *real-cnt*)) (attach-left pred succ) (return succ))) (defun link-both (left right succ) (prog (a r) (setq a (interq (left-outs left) (right-outs right))) (setq r (find-equiv-beta-node succ a)) (and r (return r)) (setq *real-cnt* (1+ *real-cnt*)) (attach-left left succ) (attach-right right succ) (return succ))) (defun attach-right (old new) (rplaca (cddr old) (cons new (caddr old)))) (defun attach-left (old new) (rplaca (cdr old) (cons new (cadr old)))) (defun right-outs (node) (caddr node)) (defun left-outs (node) (cadr node)) (defun find-equiv-node (node list) (prog (a) (setq a list) l1 (cond ((atom a) (return nil)) ((equiv node (car a)) (return (car a)))) (setq a (cdr a)) (go l1))) (defun find-equiv-beta-node (node list) (prog (a) (setq a list) l1 (cond ((atom a) (return nil)) ((beta-equiv node (car a)) (return (car a)))) (setq a (cdr a)) (go l1))) ; do not look at the predecessor fields of beta nodes; they have to be ; identical because of the way the candidate nodes were found (defun equiv (a b) (and (eq (car a) (car b)) (or (eq (car a) '&mem) (eq (car a) '&two) (equal (caddr a) (caddr b))) (equal (cdddr a) (cdddr b)))) (defun beta-equiv (a b) (and (eq (car a) (car b)) (equal (cddddr a) (cddddr b)) (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) ; the equivalence tests are set up to consider the contents of ; node memories, so they are ready for the build action ;;; Network interpreter (defun match (flag wme) (sendto flag (list wme) 'left (list *first-node*))) ; note that eval-nodelist is not set up to handle building ; productions. would have to add something like ops4's build-flag (defun eval-nodelist (nl) (prog nil top (and (not nl) (return nil)) (setq *sendtocall* nil) (setq *last-node* (car nl)) (apply (caar nl) (cdar nl)) ;; %%% here's the apply cdar nl must ;; be the *cN* item, caar nl is test (setq nl (cdr nl)) (go top))) (defun sendto (flag data side nl) (prog nil top (and (not nl) (return nil)) (setq *side* side) (setq *flag-part* flag) (setq *data-part* data) (setq *sendtocall* t) (setq *last-node* (car nl)) (apply (caar nl) (cdar nl)) ;; %%% ditto (setq nl (cdr nl)) (go top))) (defun &any (outs register const-list) (prog (z c) (setq z (symbol-value register)) (cond ((numberp z) (go number))) symbol (cond ((null const-list) (return nil)) ((eq (car const-list) z) (go ok)) (t (setq const-list (cdr const-list)) (go symbol))) number (cond ((null const-list) (return nil)) ((and (numberp (setq c (car const-list))) (=alg c z)) (go ok)) (t (setq const-list (cdr const-list)) (go number))) ok (eval-nodelist outs))) (defun teqa (outs register constant) (and (eq (symbol-value register) constant) (eval-nodelist outs))) (defun tnea (outs register constant) (and (not (eq (symbol-value register) constant)) (eval-nodelist outs))) (defun txxa (outs register constant) (declare (ignore constant)) (and (symbolp (symbol-value register)) (eval-nodelist outs))) (defun teqn (outs register constant) (prog (z) (setq z (symbol-value register)) (and (numberp z) (=alg z constant) (eval-nodelist outs)))) (defun tnen (outs register constant) (prog (z) (setq z (symbol-value register)) (and (or (not (numberp z)) (not (=alg z constant))) (eval-nodelist outs)))) (defun txxn (outs register constant) (declare (ignore constant)) (prog (z) (setq z (symbol-value register)) (and (numberp z) (eval-nodelist outs)))) (defun tltn (outs register constant) (prog (z) (setq z (symbol-value register)) (and (numberp z) (> constant z) (eval-nodelist outs)))) (defun tgtn (outs register constant) (prog (z) (setq z (symbol-value register)) (and (numberp z) (> z constant) (eval-nodelist outs)))) (defun tgen (outs register constant) (prog (z) (setq z (symbol-value register)) (and (numberp z) (not (> constant z)) (eval-nodelist outs)))) (defun tlen (outs register constant) (prog (z) (setq z (symbol-value register)) (and (numberp z) (not (> z constant)) (eval-nodelist outs)))) (defun teqs (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (cond ((eq a b) (eval-nodelist outs)) ((and (numberp a) (numberp b) (=alg a b)) (eval-nodelist outs))))) (defun tnes (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (cond ((eq a b) (return nil)) ((and (numberp a) (numberp b) (=alg a b)) (return nil)) (t (eval-nodelist outs))))) (defun txxs (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (cond ((and (numberp a) (numberp b)) (eval-nodelist outs)) ((and (not (numberp a)) (not (numberp b))) (eval-nodelist outs))))) (defun tlts (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (and (numberp a) (numberp b) (> b a) (eval-nodelist outs)))) (defun tgts (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (and (numberp a) (numberp b) (> a b) (eval-nodelist outs)))) (defun tges (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (and (numberp a) (numberp b) (not (> b a)) (eval-nodelist outs)))) (defun tles (outs vara varb) (prog (a b) (setq a (symbol-value vara)) (setq b (symbol-value varb)) (and (numberp a) (numberp b) (not (> a b)) (eval-nodelist outs)))) (defun &two (left-outs right-outs) (prog (fp dp) (cond (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*)) (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*))) (sendto fp dp 'left left-outs) (sendto fp dp 'right right-outs))) (defun &mem (left-outs right-outs memory-list) (prog (fp dp) (cond (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*)) (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*))) (sendto fp dp 'left left-outs) (add-token memory-list fp dp nil) (sendto fp dp 'right right-outs))) (defun &and (outs lpred rpred tests) (prog (mem) (cond ((eq *side* 'right) (setq mem (memory-part lpred))) (t (setq mem (memory-part rpred)))) (cond ((not mem) (return nil)) ((eq *side* 'right) (and-right outs mem tests)) (t (and-left outs mem tests))))) (defun and-left (outs mem tests) (prog (fp dp memdp tlist tst lind rind res) (setq fp *flag-part*) (setq dp *data-part*) fail (and (null mem) (return nil)) (setq memdp (car mem)) (setq mem (cdr mem)) (setq tlist tests) tloop (and (null tlist) (go succ)) (setq tst (car tlist)) (setq tlist (cdr tlist)) (setq lind (car tlist)) (setq tlist (cdr tlist)) (setq rind (car tlist)) (setq tlist (cdr tlist)) ;### (comment the next line differs in and-left & -right) (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) (cond (res (go tloop)) (t (go fail))) succ ;### (comment the next line differs in and-left & -right) (sendto fp (cons (car memdp) dp) 'left outs) (go fail))) (defun and-right (outs mem tests) (prog (fp dp memdp tlist tst lind rind res) (setq fp *flag-part*) (setq dp *data-part*) fail (and (null mem) (return nil)) (setq memdp (car mem)) (setq mem (cdr mem)) (setq tlist tests) tloop (and (null tlist) (go succ)) (setq tst (car tlist)) (setq tlist (cdr tlist)) (setq lind (car tlist)) (setq tlist (cdr tlist)) (setq rind (car tlist)) (setq tlist (cdr tlist)) ;### (comment the next line differs in and-left & -right) (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) (cond (res (go tloop)) (t (go fail))) succ ;### (comment the next line differs in and-left & -right) (sendto fp (cons (car dp) memdp) 'right outs) (go fail))) (defun teqb (new eqvar) (cond ((eq new eqvar) t) ((not (numberp new)) nil) ((not (numberp eqvar)) nil) ((=alg new eqvar) t) (t nil))) (defun tneb (new eqvar) (cond ((eq new eqvar) nil) ((not (numberp new)) t) ((not (numberp eqvar)) t) ((=alg new eqvar) nil) (t t))) (defun tltb (new eqvar) (cond ((not (numberp new)) nil) ((not (numberp eqvar)) nil) ((> eqvar new) t) (t nil))) (defun tgtb (new eqvar) (cond ((not (numberp new)) nil) ((not (numberp eqvar)) nil) ((> new eqvar) t) (t nil))) (defun tgeb (new eqvar) (cond ((not (numberp new)) nil) ((not (numberp eqvar)) nil) ((not (> eqvar new)) t) (t nil))) (defun tleb (new eqvar) (cond ((not (numberp new)) nil) ((not (numberp eqvar)) nil) ((not (> new eqvar)) t) (t nil))) (defun txxb (new eqvar) (cond ((numberp new) (cond ((numberp eqvar) t) (t nil))) (t (cond ((numberp eqvar) nil) (t t))))) (defun &p (rating name var-dope ce-var-dope rhs) (declare (ignore var-dope ce-var-dope rhs)) (prog (fp dp) (cond (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*)) (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*))) (and (member fp '(nil old)) (removecs name dp)) (and fp (insertcs name dp rating)))) (defun &old (a b c d e) (declare (ignore a b c d e)) nil) (defun ¬ (outs lmem rpred tests) (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil) ((eq *side* 'right) (not-right outs (car lmem) tests)) (t (not-left outs (memory-part rpred) tests lmem)))) (defun not-left (outs mem tests own-mem) (prog (fp dp memdp tlist tst lind rind res c) (setq fp *flag-part*) (setq dp *data-part*) (setq c 0.) fail (and (null mem) (go fin)) (setq memdp (car mem)) (setq mem (cdr mem)) (setq tlist tests) tloop (and (null tlist) (setq c (1+ c)) (go fail)) (setq tst (car tlist)) (setq tlist (cdr tlist)) (setq lind (car tlist)) (setq tlist (cdr tlist)) (setq rind (car tlist)) (setq tlist (cdr tlist)) ;### (comment the next line differs in not-left & -right) (setq res (funcall tst (gelm memdp rind) (gelm dp lind))) (cond (res (go tloop)) (t (go fail))) fin (add-token own-mem fp dp c) (and (== c 0.) (sendto fp dp 'left outs)))) (defun not-right (outs mem tests) (prog (fp dp memdp tlist tst lind rind res newfp inc newc) (setq fp *flag-part*) (setq dp *data-part*) (cond ((not fp) (setq inc -1.) (setq newfp 'new)) ((eq fp 'new) (setq inc 1.) (setq newfp nil)) (t (return nil))) fail (and (null mem) (return nil)) (setq memdp (car mem)) (setq newc (cadr mem)) (setq tlist tests) tloop (and (null tlist) (go succ)) (setq tst (car tlist)) (setq tlist (cdr tlist)) (setq lind (car tlist)) (setq tlist (cdr tlist)) (setq rind (car tlist)) (setq tlist (cdr tlist)) ;### (comment the next line differs in not-left & -right) (setq res (funcall tst (gelm dp rind) (gelm memdp lind))) (cond (res (go tloop)) (t (setq mem (cddr mem)) (go fail))) succ (setq newc (+ inc newc)) ;"plus" changed to "+" by gdw (rplaca (cdr mem) newc) (cond ((or (and (== inc -1.) (== newc 0.)) (and (== inc 1.) (== newc 1.))) (sendto newfp memdp 'right outs))) (setq mem (cddr mem)) (go fail))) ;;; Node memories (defun add-token (memlis flag data-part num) (prog (was-present) (cond ((eq flag 'new) (setq was-present nil) (real-add-token memlis data-part num)) ((not flag) (setq was-present (remove-old memlis data-part num))) ((eq flag 'old) (setq was-present t))) (return was-present))) (defun real-add-token (lis data-part num) (setq *current-token* (1+ *current-token*)) (cond (num (rplaca lis (cons num (car lis))))) (rplaca lis (cons data-part (car lis)))) (defun remove-old (lis data num) (cond (num (remove-old-num lis data)) (t (remove-old-no-num lis data)))) (defun remove-old-num (lis data) (prog (m next last) (setq m (car lis)) (cond ((atom m) (return nil)) ((top-levels-eq data (car m)) (setq *current-token* (1- *current-token*)) (rplaca lis (cddr m)) (return (car m)))) (setq next m) loop (setq last next) (setq next (cddr next)) (cond ((atom next) (return nil)) ((top-levels-eq data (car next)) (rplacd (cdr last) (cddr next)) (setq *current-token* (1- *current-token*)) (return (car next))) (t (go loop))))) (defun remove-old-no-num (lis data) (prog (m next last) (setq m (car lis)) (cond ((atom m) (return nil)) ((top-levels-eq data (car m)) (setq *current-token* (1- *current-token*)) (rplaca lis (cdr m)) (return (car m)))) (setq next m) loop (setq last next) (setq next (cdr next)) (cond ((atom next) (return nil)) ((top-levels-eq data (car next)) (rplacd last (cdr next)) (setq *current-token* (1- *current-token*)) (return (car next))) (t (go loop))))) ;;; Conflict Resolution ; ; ; each conflict set element is a list of the following form: ; ((p-name . data-part) (sorted wm-recency) special-case-number) (defun order-tags (dat) (prog (tags) (setq tags nil) l1p (and (atom dat) (go l2p)) (setq tags (cons (creation-time (car dat)) tags)) (setq dat (cdr dat)) (go l1p) l2p (cond ((eq *strategy* 'mea) (return (cons (car tags) (dsort (cdr tags))))) (t (return (dsort tags)))))) ; destructively sort x into descending order (defun dsort (x) (prog (sorted cur next cval nval) (and (atom (cdr x)) (return x)) loop (setq sorted t) (setq cur x) (setq next (cdr x)) chek (setq cval (car cur)) (setq nval (car next)) (cond ((> nval cval) (setq sorted nil) (rplaca cur nval) (rplaca next cval))) (setq cur next) (setq next (cdr cur)) (cond ((not (null next)) (go chek)) (sorted (return x)) (t (go loop))))) (defun order-part (conflict-elem) (cdr conflict-elem)) (defun conflict-set-compare (x y) (prog (x-order y-order xl yl xv yv) (setq x-order (order-part x)) (setq y-order (order-part y)) (setq xl (car x-order)) (setq yl (car y-order)) data (cond ((and (null xl) (null yl)) (go ps)) ((null yl) (return t)) ((null xl) (return nil))) (setq xv (car xl)) (setq yv (car yl)) (cond ((> xv yv) (return t)) ((> yv xv) (return nil))) (setq xl (cdr xl)) (setq yl (cdr yl)) (go data) ps (setq xl (cdr x-order)) (setq yl (cdr y-order)) psl (cond ((null xl) (return t))) (setq xv (car xl)) (setq yv (car yl)) (cond ((> xv yv) (return t)) ((> yv xv) (return nil))) (setq xl (cdr xl)) (setq yl (cdr yl)) (go psl))) ;;; WM maintaining functions ; ; The order of operations in the following two functions is critical. ; add-to-wm order: (1) change wm (2) record change (3) match ; remove-from-wm order: (1) record change (2) match (3) change wm ; (back will not restore state properly unless wm changes are recorded ; before the cs changes that they cause) (match will give errors if ; the thing matched is not in wm at the time) ; remove-from-wm uses eq, not equal to determine if wme is present ; mapwm maps down the elements of wm, applying fn to each element ; each element is of form (datum . creation-time) (defun mapwm (fn) (prog (wmpl part) (setq wmpl *wmpart-list*) lab1 (cond ((atom wmpl) (return nil))) (setq part (get (car wmpl) 'wmpart*)) (setq wmpl (cdr wmpl)) (mapc fn part) (go lab1))) (defun ops-wm (a) (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) (get-wm a)) nil) (defun get-wm (z) (setq *wm-filter* z) (setq *wm* nil) (mapwm (function get-wm2)) (prog2 nil *wm* (setq *wm* nil))) (defun get-wm2 (elem) (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) (setq *wm* (cons (car elem) *wm*))))) (defun creation-time (wme) (cdr (soarassq wme (get (wm-hash wme) 'wmpart*)))) (defun refresh nil (prog nil (setq *old-wm* nil) (mapwm (function refresh-collect)) (mapc (function refresh-del) *old-wm*) (mapc (function refresh-add) *old-wm*) (setq *old-wm* nil))) (defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) (defun refresh-del (x) (remove-from-wm (car x))) ;;;soar redefined add-to-wm ;;;;(defun refresh-add (x) (add-to-wm (car x) (cdr x))) (defun trace-file () (prog (port) (setq port *standard-output*) (cond (*trace-file* (setq port ($ofile *trace-file*)) (cond ((null port) (%warn '|trace: file has been closed| *trace-file*) (setq port *standard-output*))))) (return port))) ;;; Basic functions for RHS evaluation (defun time-tag-print (data port) (cond ((not (null data)) (time-tag-print (cdr data) port) (princq '| | port) (princq (creation-time (car data)) port)))) (defun init-var-mem (vlist) (prog (v ind r) (setq *variable-memory* nil) top (and (atom vlist) (return nil)) (setq v (car vlist)) (setq ind (cadr vlist)) (setq vlist (cddr vlist)) (setq r (gelm *data-matched* ind)) (setq *variable-memory* (cons (cons v r) *variable-memory*)) (go top))) (defun init-ce-var-mem (vlist) (prog (v ind r) (setq *ce-variable-memory* nil) top (and (atom vlist) (return nil)) (setq v (car vlist)) (setq ind (cadr vlist)) (setq vlist (cddr vlist)) (setq r (ce-gelm *data-matched* ind)) (setq *ce-variable-memory* (cons (cons v r) *ce-variable-memory*)) (go top))) (defun make-ce-var-bind (var elem) (setq *ce-variable-memory* (cons (cons var elem) *ce-variable-memory*))) (defun make-var-bind (var elem) (setq *variable-memory* (cons (cons var elem) *variable-memory*))) (defun get-ce-var-bind (x) (prog (r) (cond ((numberp x) (return (get-num-ce x)))) (setq r (soarassq x *ce-variable-memory*)) (cond (r (return (cdr r))) (t (return nil))))) (defun get-num-ce (x) (prog (r l d) (setq r *data-matched*) (setq l (length r)) (setq d (- l x)) (and (> 0. d) (return nil)) la (cond ((null r) (return nil)) ((> 1. d) (return (car r)))) (setq d (1- d)) (setq r (cdr r)) (go la))) (defun build-collect (z) (prog (r) la (and (atom z) (return nil)) (setq r (car z)) (setq z (cdr z)) (cond ((consp r) ;dtpr\consp gdw ($value '\() (build-collect r) ($value '\))) ((eq r '\\) ($change (car z)) (setq z (cdr z))) (t ($value r))) (go la))) (defun unflat (x) (setq *rest* x) (unflat*)) (defun unflat* nil (prog (c) (cond ((atom *rest*) (return nil))) (setq c (car *rest*)) (setq *rest* (cdr *rest*)) (cond ((eq c '\() (return (cons (unflat*) (unflat*)))) ((eq c '\)) (return nil)) (t (return (cons c (unflat*))))))) (defun $change (x) (prog nil (cond ((consp x) (eval-function x)) ;dtpr\consp gdw (t ($value ($varbind x)))))) (defun eval-args (z) (prog (r) (rhs-tab 1.) la (and (atom z) (return nil)) (setq r (car z)) (setq z (cdr z)) (cond ((EQ R '^) (RHS-tab (car z)) (setq r (cadr z)) (setq z (cddr z)))) (cond ((eq r '//) ($value (car z)) (setq z (cdr z))) (t ($change r))) (go la))) (defun eval-function (form) (cond ((not *in-rhs*) (%warn '|functions cannot be used at top level| (car form))) (t (eval form)))) ;;; Functions to manipulate the result array (defun $reset nil (setq *max-index* 0.) (setq *next-index* 1.)) (defun rhs-tab (z) ($tab ($varbind z))) (defun $tab (z) (prog (edge next) (setq next ($litbind z)) (and (floatp next) (setq next (fix next))) (cond ((or (not (numberp next)) (> next *size-result-array*) (> 1. next)) ; ( '| |) (%warn '|illegal index after ^| next) (return *next-index*))) (setq edge (- next 1.)) (cond ((> *max-index* edge) (go ok))) clear (cond ((== *max-index* edge) (go ok))) (putvector *result-array* edge nil) (setq edge (1- edge)) (go clear) ok (setq *next-index* next) (return next))) (defun $value (v) (cond ((> *next-index* *size-result-array*) (%warn '|index too large| *next-index*)) (t (and (> *next-index* *max-index*) (setq *max-index* *next-index*)) (putvector *result-array* *next-index* v) (setq *next-index* (1+ *next-index*))))) (defun use-result-array nil (prog (k r) (setq k *max-index*) (setq r nil) top (and (== k 0.) (return r)) (setq r (cons (getvector *result-array* k) r)) (setq k (1- k)) (go top))) (defun $assert nil (setq *last* (use-result-array)) (add-to-wm *last*)) (defun $parametercount nil *max-index*) (defun $parameter (k) (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.)) (%warn '|illegal parameter number | k) nil) ((> k *max-index*) nil) (t (getvector *result-array* k)))) ;;; RHS actions (defun ops-make (z) (prog nil ($reset) (eval-args z) ($assert))) (defun ops-modify (z) (prog (old) (cond ((not *in-rhs*) (%warn '|cannot be called at top level| 'modify) (return nil))) (setq old (get-ce-var-bind (car z))) (cond ((null old) (%warn '|modify: first argument must be an element variable| (car z)) (return nil))) (remove-from-wm old) (setq z (cdr z)) ($reset) copy (and (atom old) (go fin)) ($change (car old)) (setq old (cdr old)) (go copy) fin (eval-args z) ($assert))) (defun ops-cbind (z) (cond ((not *in-rhs*) (%warn '|cannot be called at top level| 'cbind)) ((not (= (length z) 1.)) (%warn '|cbind: wrong number of arguments| z)) ((not (symbolp (car z))) (%warn '|cbind: illegal argument| (car z))) ((null *last*) (%warn '|cbind: nothing added yet| (car z))) (t (make-ce-var-bind (car z) *last*)))) (defun ops-remove (z) (prog (old) (and (not *in-rhs*)(return (top-level-remove z))) top (and (atom z) (return nil)) (setq old (get-ce-var-bind (car z))) (cond ((null old) (%warn '|remove: argument not an element variable| (car z)) (return nil))) (remove-from-wm old) (setq z (cdr z)) (go top))) (defun ops-call1 (z) (prog (f) (setq f (car z)) ($reset) (eval-args (cdr z)) (funcall f))) (defmacro append-string (x) `(setq wrstring (concatenate 'simple-string wrstring ,x))) (defun default-write-file () (prog (port) (setq port *standard-output*) (cond (*write-file* (setq port ($ofile *write-file*)) (cond ((null port) (%warn '|write: file has been closed| *write-file*) (setq port *standard-output*))))) (return port))) (defun do-rjust (width value port) (prog (size) (cond ((eq value '|=== T A B T O ===|) (%warn '|rjust cannot precede this function| 'tabto) (return nil)) ((eq value '|=== C R L F ===|) (%warn '|rjust cannot precede this function| 'crlf) (return nil)) ((eq value '|=== R J U S T ===|) (%warn '|rjust cannot precede this function| 'rjust) (return nil))) ;original-> (setq size (flatc value (1+ width))) (setq size (min value (1+ width))) ;### KLUGE (cond ((> size width) (princq '| | port) (princq value port) (return nil))) (princq value port))) (defun do-tabto (col &optional port) (prog (pos) (finish-output port);kluge (setq pos 0);kluge (do ((k (- col pos) (1- k))) ((not (> k 0))) (princq '| | port)) (return nil))) (defun halt nil (cond ((not *in-rhs*) (%warn '|cannot be called at top level| 'halt)) (t (setq *halt-flag* t)))) (defun ops-build (z) (prog (r) (cond ((not *in-rhs*) (%warn '|cannot be called at top level| 'build) (return nil))) ($reset) (build-collect z) (setq r (unflat (use-result-array))) (and *build-trace* (funcall *build-trace* r)) (compile-production (car r) (cdr r)))) (defun ops-openfile (z) (prog (file mode id) ($reset) (eval-args z) (cond ((not (equal ($parametercount) 3.)) (%warn '|openfile: wrong number of arguments| z) (return nil))) (setq id ($parameter 1)) (setq file ($parameter 2)) (setq mode ($parameter 3)) (cond ((not (symbolp id)) (%warn '|openfile: file id must be a symbolic atom| id) (return nil)) ((null id) (%warn '|openfile: 'nil' is reserved for the terminal| nil) (return nil)) ((or ($ifile id)($ofile id)) (%warn '|openfile: name already in use| id) (return nil))) (cond ((eq mode 'in) (soarputprop id (setq id (infile file)) 'inputfile)) ((eq mode 'out) (soarputprop id (setq id (outfile file)) 'outputfile)) (t (%warn '|openfile: illegal mode| mode) (return nil))) (return nil))) (defun $ifile (x) (cond ((symbolp x) (get x 'inputfile)) (t nil))) (defun $ofile (x) (cond ((symbolp x) (get x 'outputfile)) (t nil))) (defun ops-closefile (z) ($reset) (eval-args z) (mapc (function closefile2) (use-result-array))) (defun closefile2 (file) (prog (port) (cond ((not (symbolp file)) (%warn '|closefile: illegal file identifier| file)) ((setq port ($ifile file)) (close port) (remprop file 'inputfile)) ((setq port ($ofile file)) (close port) (remprop file 'outputfile))) (return nil))) (defun ops-default (z) (prog (file use) ($reset) (eval-args z) (cond ((not (equal ($parametercount) 2.)) (%warn '|default: wrong number of arguments| z) (return nil))) (setq file ($parameter 1)) (setq use ($parameter 2)) (cond ((not (symbolp file)) (%warn '|default: illegal file identifier| file) (return nil)) ((not (member use '(write accept trace) :test #'equal)) (%warn '|default: illegal use for a file| use) (return nil)) ((and (member use '(write trace) :test #'equal) (not (null file)) (not ($ofile file))) (%warn '|default: file has not been opened for output| file) (return nil)) ((and (equal use 'accept) (not (null file)) (not ($ifile file))) (%warn '|default: file has not been opened for input| file) (return nil)) ((equal use 'write) (setq *write-file* file)) ((equal use 'accept) (setq *accept-file* file)) ((equal use 'trace) (setq *trace-file* file))) (return nil))) (defun flat-value (x) (cond ((atom x) ($value x)) (t (mapc (function flat-value) x)))) (defun ops-accept (z) (prog (port arg) (cond ((> (length z) 1.) (%warn '|accept: wrong number of arguments| z) (return nil))) (setq port *standard-input*) (cond (*accept-file* (setq port ($ifile *accept-file*)) (cond ((null port) (%warn '|accept: file has been closed| *accept-file*) (return nil))))) (cond ((= (length z) 1) (setq arg ($varbind (car z))) (cond ((not (symbolp arg)) (%warn '|accept: illegal file name| arg) (return nil))) (setq port ($ifile arg)) (cond ((null port) (%warn '|accept: file not open for input| arg) (return nil))))) (cond ((equal (peek-char t port nil "eof" ) "eof" ) ($value 'end-of-file) (return nil))) (flat-value (read port)))) (defun ops-acceptline (z) (let ((port *standard-input*) (def z)) (cond (*accept-file* (setq port ($ifile *accept-file*)) (cond ((null port) (%warn '|acceptline: file has been closed| *accept-file*) (return-from ops-acceptline nil))))) (cond ((> (length def) 0) (let ((arg ($varbind (car def)))) (cond ((and (symbolp arg) ($ifile arg)) (setq port ($ifile arg)) (setq def (cdr def))))))) (let ((line (read-line port nil 'eof))) (declare (simple-string line)) ;; Strip meaningless characters from start and end of string. (setq line (string-trim '(#\( #\) #\, #\tab #\space) line)) (when (equal line "") (mapc (function $change) def) (return-from ops-acceptline nil)) (setq line (concatenate 'simple-string "(" line ")")) ;; Read all items from the line (flat-value (read-from-string line))))) (defun ops-substr (l) (prog (k elm start end) (cond ((not (= (length l) 3.)) (%warn '|substr: wrong number of arguments| l) (return nil))) (setq elm (get-ce-var-bind (car l))) (cond ((null elm) (%warn '|first argument to substr must be a ce var| l) (return nil))) (setq start ($varbind (cadr l))) (setq start ($litbind start)) (cond ((not (numberp start)) (%warn '|second argument to substr must be a number| l) (return nil))) ;### (comment |if a variable is bound to INF, the following| ; |will get the binding and treat it as INF is| ; |always treated. that may not be good|) (setq end ($varbind (caddr l))) (cond ((eq end 'inf) (setq end (length elm)))) (setq end ($litbind end)) (cond ((not (numberp end)) (%warn '|third argument to substr must be a number| l) (return nil))) (setq k 1.) la (cond ((> k end) (return nil)) ((not (< k start)) ($value (car elm)))) (setq elm (cdr elm)) (setq k (1+ k)) (go la))) (defun ops-compute (z) ($value (ari z))) (defun ops-arith (z) ($value (ari z))) (defun ari (x) (cond ((atom x) (%warn '|bad syntax in arithmetic expression | x) 0.) ((atom (cdr x)) (ari-unit (car x))) ((eq (cadr x) '+) (+ (ari-unit (car x)) (ari (cddr x)))) ;"plus" changed to "+" by gdw ((eq (cadr x) '-) (- (ari-unit (car x)) (ari (cddr x)))) ((eq (cadr x) '*) (* (ari-unit (car x)) (ari (cddr x)))) ((eq (cadr x) '//) (floor (ari-unit (car x)) (ari (cddr x)))) ;@@@ quotient? / ;@@@ kluge only works for integers ;@@@ changed to floor by jcp (from round) ((eq (cadr x) '\\) (mod (fix (ari-unit (car x))) (fix (ari (cddr x))))) (t (%warn '|bad syntax in arithmetic expression | x) 0.))) (defun ari-unit (a) (prog (r) (cond ((consp a) (setq r (ari a))) ;dtpr\consp gdw (t (setq r ($varbind a)))) (cond ((not (numberp r)) (%warn '|bad value in arithmetic expression| a) (return 0.)) (t (return r))))) (defun genatom nil ($value (gensym))) (defun ops-litval (z) (prog (r) (cond ((not (= (length z) 1.)) (%warn '|litval: wrong number of arguments| z) ($value 0) (return nil)) ((numberp (car z)) ($value (car z)) (return nil))) (setq r ($litbind ($varbind (car z)))) (cond ((numberp r) ($value r) (return nil))) (%warn '|litval: argument has no literal binding| (car z)) ($value 0))) ;;; Printing WM (defun ppwm2 (elm-tag) (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) (default-write-file))))) (defun filter (elm) (prog (fl indx val) (setq fl *filters*) top (and (atom fl) (return t)) (setq indx (car fl)) (setq val (cadr fl)) (setq fl (cddr fl)) (and (ident (nth (1- indx) elm) val) (go top)) (return nil))) (defun ident (x y) (cond ((eq x y) t) ((not (numberp x)) nil) ((not (numberp y)) nil) ((=alg x y) t) (t nil))) ; the new ppelm is designed especially to handle literalize format ; however, it will do as well as the old ppelm on other formats (defun ppelm (elm port) (prog (ppdat sep val att mode lastpos) (princq (creation-time elm) port) (princq '|: | port) (setq mode 'vector) (setq ppdat (get (car elm) 'ppdat)) (and ppdat (setq mode 'a-v)) (setq sep "(") ; ")" (setq lastpos 0) (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist))) ((atom vlist) nil) ; terminate (setq val (car vlist)) ; tagbody begin (setq att (assoc curpos ppdat)) ;should ret (curpos attr-name) (cond (att (setq att (cdr att))) ; att = (attr-name) ?? (t (setq att curpos))) (and (symbolp att) (is-vector-attribute att) (setq mode 'vector)) (cond ((or (not (null val)) (eq mode 'vector)) (princq sep port) (ppval val att lastpos port) (setq sep '| |) (setq lastpos curpos)))) (princq '|)| port))) (defun ppval (val att lastpos port) ; (break "in ppval") (cond ((not (equal att (1+ lastpos))) ; ok, if we got an att (princq '^ port) (princq att port) (princq '| | port))) (princq val port)) ;;; printing production memory (defun ppline2 () (prog (needspace) (setq needspace nil) top (and (atom *ppline*) (return nil)) (and needspace (princ '| |)) (cond ((eq (car *ppline*) '^) (ppattval)) (t (pponlyval))) (setq needspace t) (go top))) (defun getval () (prog (res v1) (setq v1 (car *ppline*)) (setq *ppline* (cdr *ppline*)) (cond ((member v1 '(= <> < <= => > <=>)) (setq res (cons v1 (getval)))) ((eq v1 '{) (setq res (cons v1 (getupto '})))) ((eq v1 '<<) (setq res (cons v1 (getupto '>>)))) ((eq v1 '//) (setq res (list v1 (car *ppline*))) (setq *ppline* (cdr *ppline*))) (t (setq res (list v1)))) (return res))) (defun getupto (end) (prog (v) (and (atom *ppline*) (return nil)) (setq v (car *ppline*)) (setq *ppline* (cdr *ppline*)) (cond ((eq v end) (return (list v))) (t (return (cons v (getupto end))))))) ;;; backing up (defun record-index-plus (k) (setq *record-index* (+ k *record-index*)) ;"plus" changed to "+" by gdw (cond ((< *record-index* 0.) (setq *record-index* *max-record-index*)) ((> *record-index* *max-record-index*) (setq *record-index* 0.)))) (defun initialize-record nil (setq *record-index* 0.) (setq *recording* nil) (setq *max-record-index* 31.) (putvector *record-array* 0. nil)) (defun begin-record (p data) (setq *recording* t) (setq *record* (list '=>refract p data))) (defun end-record nil (cond (*recording* (setq *record* (cons *cycle-count* (cons *p-name* *record*))) (record-index-plus 1.) (putvector *record-array* *record-index* *record*) (setq *record* nil) (setq *recording* nil)))) (defun record-change (direct time elm) (cond (*recording* (setq *record* (cons direct (cons time (cons elm *record*))))))) (defun record-refract (rule data) (and *recording* (setq *record* (cons '<=refract (cons rule (cons data *record*)))))) (defun refracted (rule data) (prog (z) (and (null *refracts*) (return nil)) (setq z (cons rule data)) (return (member z *refracts* :test #'equal)))) (defun back (k) (prog (r) loop (and (< k 1.) (return nil)) (setq r (getvector *record-array* *record-index*)) ; ((')) (and (null r) (return '|nothing more stored|)) (putvector *record-array* *record-index* nil) (record-index-plus -1.) (undo-record r) (setq k (1- k)) (go loop))) (defun undo-record (r) (prog (save act a b rate) (setq save *recording*) (setq *refracts* nil) (setq *recording* nil) (and *ptrace* (back-print (list '|undo:| (car r) (cadr r)))) (setq r (cddr r)) top (and (atom r) (go fin)) (setq act (car r)) (setq a (cadr r)) (setq b (caddr r)) (setq r (cdddr r)) (and *wtrace* (back-print (list '|undo:| act a))) (cond ((eq act '<=wm) (add-to-wm b a)) ((eq act '=>wm) (remove-from-wm b)) ((eq act '<=refract) (setq *refracts* (cons (cons a b) *refracts*))) ((and (eq act '=>refract) (still-present b)) (setq *refracts* (spdelete (cons a b) *refracts*)) (setq rate (rating-part (get a 'topnode))) (removecs a b) (insertcs a b rate)) (t (%warn '|back: cannot undo action| (list act a)))) (go top) fin (setq *recording* save) (setq *refracts* nil) (return nil))) (defun still-present (data) (prog nil loop (cond ((atom data) (return t)) ((creation-time (car data)) (setq data (cdr data)) (go loop)) (t (return nil))))) (defun back-print (x) (prog (port) (setq port (trace-file)) (terpri port) (print x port))) (defun ops-matches (rule-list) (mapc (function matches2) rule-list) (terpri)) (defun matches2 (p) (cond ((atom p) (terpri) (terpri) (princ p) (matches3 (get p 'backpointers) 2. (ncons 1.))))) (defun matches3 (nodes ce part) (cond ((not (null nodes)) (terpri) (princ '| ** matches for |) (princ part) (princ '| ** |) (mapc (function write-elms) (find-left-mem (car nodes))) (terpri) (princ '| ** matches for |) (princ (ncons ce)) (princ '| ** |) (mapc (function write-elms) (find-right-mem (car nodes))) (matches3 (cdr nodes) (1+ ce) (cons ce part))))) (defun write-elms (wme-or-count) (cond ((consp wme-or-count) ;dtpr\consp gdw (terpri) (mapc (function write-elms2) wme-or-count)))) (defun write-elms2 (x) (princ '| |) (princ (creation-time x))) (defun find-left-mem (node) (cond ((eq (car node) '&and) (memory-part (caddr node))) (t (car (caddr node))))) (defun find-right-mem (node) (memory-part (cadddr node))) ;;; Check the RHSs of productions (defun check-rhs (rhs) (mapc (function check-action) rhs)) (defun check-build (z) (and (null (cdr z)) (%warn '|needs arguments| z)) (check-build-collect (cdr z))) (defun check-build-collect (args) (prog (r) top (and (null args) (return nil)) (setq r (car args)) (setq args (cdr args)) (cond ((consp r) (check-build-collect r)) ;dtpr\consp gdw ((eq r '\\) (and (null args) (%warn '|nothing to evaluate| r)) (check-rhs-value (car args)) (setq args (cdr args)))) (go top))) (defun check-remove (z) ;@@@ kluge by gdw (and (null (cdr z)) (%warn '|needs arguments| z)) (mapc (function check-rhs-ce-var) (cdr z))) (defun check-openfile (z) (and (null (cdr z)) (%warn '|needs arguments| z)) (check-change& (cdr z))) (defun check-closefile (z) (and (null (cdr z)) (%warn '|needs arguments| z)) (check-change& (cdr z))) (defun check-default (z) (and (null (cdr z)) (%warn '|needs arguments| z)) (check-change& (cdr z))) (defun check-write (z) ;note this works w/write (and (null (cdr z)) (%warn '|needs arguments| z)) (check-change& (cdr z))) (defun check-call1 (z) (prog (f) (and (null (cdr z)) (%warn '|needs arguments| z)) (setq f (cadr z)) (and (variablep f) (%warn '|function name must be a constant| z)) (or (symbolp f) (%warn '|function name must be a symbolic atom| f)) (or (externalp f) (%warn '|function name not declared external| f)) (check-change& (cddr z)))) (defun check-halt (z) (or (null (cdr z)) (%warn '|does not take arguments| z))) (defun check-cbind (z) (prog (v) (or (= (length z) 2.) (%warn '|takes only one argument| z)) (setq v (cadr z)) (or (variablep v) (%warn '|takes variable as argument| z)) (note-ce-variable v))) (defun check-bind (z) (prog (v) (or (> (length z) 1.) (%warn '|needs arguments| z)) (setq v (cadr z)) (or (variablep v) (%warn '|takes variable as argument| z)) (note-variable v) (check-change& (cddr z)))) (defun check-change& (z) (prog (r tab-flag) (setq tab-flag nil) la (and (atom z) (return nil)) (setq r (car z)) (setq z (cdr z)) (cond ((eq r '^) (and tab-flag (%warn '|no value before this tab| (car z))) (setq tab-flag t) (check-tab-index (car z)) (setq z (cdr z))) ((eq r '//) (setq tab-flag nil) (setq z (cdr z))) (t (setq tab-flag nil) (check-rhs-value r))) (go la))) (defun check-rhs-ce-var (v) (cond ((and (not (numberp v)) (not (ce-bound? v))) (%warn '|unbound element variable| v)) ((and (numberp v) (or (< v 1.) (> v *ce-count*))) (%warn '|numeric element designator out of bounds| v)))) (defun check-rhs-atomic (x) (and (variablep x) (not (bound? x)) (%warn '|unbound variable| x))) (defun check-rhs-function (x) (prog (a) (setq a (car x)) (cond ((eq a 'compute) (check-compute x)) ((eq a 'arith) (check-compute x)) ((eq a 'substr) (check-substr x)) ((eq a 'accept) (check-accept x)) ((eq a 'acceptline) (check-acceptline x)) ((eq a 'crlf) (check-crlf x)) ((eq a 'genatom) (check-genatom x)) ((eq a 'litval) (check-litval x)) ((eq a 'tabto) (check-tabto x)) ((eq a 'rjust) (check-rjust x)) ((not (externalp a)) (%warn '"rhs function not declared external" a))))) (defun check-litval (x) (or (= (length x) 2) (%warn '|wrong number of arguments| x)) (check-rhs-atomic (cadr x))) (defun check-accept (x) (cond ((= (length x) 1) nil) ((= (length x) 2) (check-rhs-atomic (cadr x))) (t (%warn '|too many arguments| x)))) (defun check-acceptline (x) (mapc (function check-rhs-atomic) (cdr x))) (defun check-crlf (x) (check-0-args x)) (defun check-genatom (x) (check-0-args x)) (defun check-tabto (x) (or (= (length x) 2) (%warn '|wrong number of arguments| x)) (check-print-control (cadr x))) (defun check-rjust (x) (or (= (length x) 2) (%warn '|wrong number of arguments| x)) (check-print-control (cadr x))) (defun check-0-args (x) (or (= (length x) 1.) (%warn '|should not have arguments| x))) (defun check-substr (x) (or (= (length x) 4.) (%warn '|wrong number of arguments| x)) (check-rhs-ce-var (cadr x)) (check-substr-index (caddr x)) (check-last-substr-index (cadddr x))) (defun check-compute (x) (check-arithmetic (cdr x))) (defun check-arithmetic (l) (cond ((atom l) (%warn '|syntax error in arithmetic expression| l)) ((atom (cdr l)) (check-term (car l))) ((not (member (cadr l) '(+ - * // \\))) ;"plus" changed to "+" by gdw (%warn '|unknown operator| l)) (t (check-term (car l)) (check-arithmetic (cddr l))))) (defun check-term (x) (cond ((consp x) (check-arithmetic x)) ;dtpr\consp gdw (t (check-rhs-atomic x)))) (defun check-last-substr-index (x) (or (eq x 'inf) (check-substr-index x))) (defun check-substr-index (x) (prog (v) (cond ((bound? x) (return x))) (setq v ($litbind x)) (cond ((not (numberp v)) (%warn '|unbound symbol used as index in substr| x)) ((or (< v 1.) (> v 127.)) (%warn '|index out of bounds in tab| x))))) (defun check-print-control (x) (prog () (cond ((bound? x) (return x))) (cond ((or (not (numberp x)) (< x 1.) (> x 127.)) (%warn '|illegal value for printer control| x))))) (defun check-tab-index (x) (prog (v) (cond ((bound? x) (return x))) (setq v ($litbind x)) (cond ((not (numberp v)) (%warn '|unbound symbol occurs after ^| x)) ((or (< v 1.) (> v 127.)) (%warn '|index out of bounds after ^| x))))) (defun note-variable (var) (setq *rhs-bound-vars* (cons var *rhs-bound-vars*))) (defun bound? (var) (or (member var *rhs-bound-vars*) (var-dope var))) (defun note-ce-variable (ce-var) (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*))) (defun ce-bound? (ce-var) (or (member ce-var *rhs-bound-ce-vars*) (ce-var-dope ce-var))) ;;; Top level routines (defun process-changes (adds dels) (prog (x) process-deletes (and (atom dels) (go process-adds)) (setq x (car dels)) (setq dels (cdr dels)) (remove-from-wm x) (go process-deletes) process-adds (and (atom adds) (return nil)) (setq x (car adds)) (setq adds (cdr adds)) (add-to-wm x nil) (go process-adds))) (defun check-limits nil (cond ((> (length *conflict-set*) *limit-cs*) (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%" *limit-cs* *p-name*) (setq *halt-flag* t))) (cond ((> *current-token* *limit-token*) (format t "~%~%token memory size exceeded the limit of ~D after ~D~%" *limit-token* *p-name*) (setq *halt-flag* t)))) (defun top-level-remove (z) (cond ((equal z '(*)) (process-changes nil (get-wm nil))) (t (process-changes nil (get-wm z))))) (defun ops-excise (z) (mapc (function excise-p) z)) (defun ops-strategy (z) (cond ((atom z) *strategy*) ((equal z '(lex)) (setq *strategy* 'lex)) ((equal z '(mea)) (setq *strategy* 'mea)) (t 'what?))) (defun ops-cs (z) (cond ((atom z) (conflict-set)) (t 'what?))) (defun ops-external (z) (catch '!error! (external2 z))) (defun external2 (z) (mapc (function external3) z)) (defun external3 (x) (cond ((symbolp x) (soarputprop x t 'external-routine)) (t (%error '|not a legal function name| x)))) (defun externalp (x) (cond ((symbolp x) t) (t (%warn '|not a legal function name| x) nil))) (defun rematm (atm list) (cond ((atom list) list) ((eq atm (car list)) (rematm atm (cdr list))) (t (cons (car list) (rematm atm (cdr list)))))) (defun broken (rule) (member rule *brkpts*)) (defun fix (x) (floor x)) (defun infile (f_name) (open f_name :direction :input)) (defun sequencep (x) (typep x 'sequence)) (defun outfile (f_name) (open f_name :direction :output :if-exists :new-version)) ;********** ; Soar 4.0 ;********** (proclaim '(special *3600-display* *action-closure* *action-list* *already-fired* *always-learn* *attribute-index* *begin-time* *big-index* *big-info-index* *brknames* *brkrun* *cav* *cavi* *chunk-all-paths* *chunk-classes* *chunk-free-problem-spaces* *chunks* *closure* *condition-list* *condition-vars* *context* *context-field-found* *context-stack* *copy-action-list* *created-list* *creating-subgoal* *current-goal* *current-list* *current-preferences* *current-production-trace* *data-matched* *decide-count* *decide-trace* *default-multi* *default-user-select* *dtrace* *elaborations-count* *elapsed-time* *first-action* *first-remove* *free-gensym-list* *free-pname-list* *global-pair* *goal-index* *gtrace* *id-index* *impasse-subset-not-equal* *indent* *init-wm* *instance-attributes* *interlisp* *last-value-var* *learn-ids* *learning* *ltrace* *max-chunk-conditions* *max-elaborations* *max-recurse* *multi-attribute* *never-learn* *new-chunks* *new-contexts* *new-root* *operator-index* *ops5-actions* *order-trace* *otrace* *p-type* *pick-first-condition* *pnames* *preference-found* *print-attribute-list* *print-learn* *print-pname* *print-spo-list* *prior-operator* *problem-space-index* *prod-count* *rcontext* *rcontext-stack* *remaining-decide* *result* *save-action* *save-class-list* *save-condition* *select-equal* *slot-index* *smaller-chunks* *sp-classes* *split-actions* *spo-default-depth* *state-index* *strace* *sub-context* *subgoal-results* *subgoal-tabs* *suspected-duplicates* *trace-number* *tracep* *tracep-list* *ttrace* *unbound* *unbound-action-ids* *used-char-list* *used-gensym-list* *used-var-list* *user-ids* *value-index* *variable-pairs* *version-number* *warning* *watch-free-problem-spaces* *wme-list-stack*)) ; ****************************** ;;; Macros and functions to help in the conversion of the Soar system ;;; from Interlisp to Commonlisp. (defmacro soarterpri (&body z) (cons 'terpri z)) (defmacro smake (&body z) (cond ((assoc (car z) *sp-classes*) (spm-to-make z)) (t (cons 'make z)))) (defmacro soarwarn (&body z) (cons '%warn z)) ; Using Ops5 %warn function (defmacro %%warn (&body z) (cons '%warn z)) ; Using Ops5 %warn function (defmacro %%error (&body z) (cons '%error z)) ; Using Ops5 %error function (defmacro soarsort (list) `(sort ,list #'string-lessp)) (defmacro soardelq (item list) `(delete ,item ,list :test #'eq)) (defmacro dremove (item list) `(delete ,item ,list :test #'eq)) (defmacro soarassoc (item alist) `(assoc ,item ,alist :test #'equalp)) (defmacro soarmemq (item list) `(member ,item ,list :test #'eq)) (defmacro soarmember (item list) `(member ,item ,list :test #'equalp)) (defun addprop (n a v) (soarputprop n (cons v (get n a)) a)) (defmacro soarmapc (func list) `(mapc ,func ,list)) (defmacro soarmapcar (func list) `(mapcar ,func ,list)) (defmacro soarmapconc (func list) `(mapcan ,func ,list)) (defmacro soarpush (item list) `(push ,item ,list)) (defmacro quotient (x y) `(float (/ ,x ,y))) (defmacro neq (&body z) (list 'not (cons 'eq z))) (defmacro copy (thing) `(copy-tree ,thing)) (defmacro soarnth (ind list) `(nth ,ind ,list)) (defmacro soarnthcdr (ind list) `(nthcdr ,ind ,list)) (defmacro alwaystime () `(get-internal-run-time)) (defmacro time-conversion (tempus) `(float (/ ,tempus internal-time-units-per-second))) (defmacro init-gensym (&body z) (declare (ignore z)) `(gensym 0) ) (defun soargensymbol (x) (gentemp (string x))) (defun soarnthchar (sym num) (char (string sym) (- num 1))) (defun soarpack (a b c d) (intern (format nil "~A~A~D~A" a b c d))) (defun soarpack2 (a b) (intern (format nil "~A~A" a b))) (defmacro soarload (f) `(load ,f)) (defmacro soar-do (&body z) (cons 'do z)) (defmacro soarwhile (test &body z) (append (list 'do '() (list (list 'not test))) z)) (defun rplnode (x c d) (rplaca x c) (rplacd x d)) (defmacro soarcarsort (x) `(sort ,x #'string-lessp :key #'car)) (defmacro array (n) `(make-array ,n :initial-element () )) (defmacro makevector (n) `(make-array ,n :initial-element () )) (defmacro soarcatch (&body z) (cons 'catch z)) (defmacro *throw (&body z) (cons 'throw z)) (defmacro readp (z) `(listen ,z)) (defmacro concat (&body z) (cons 'concatenate (cons '(quote string) z))) (defmacro dreverse (x) `(nreverse ,x)) (eval-when (compile load eval) (set-macro-character #\{ #'(lambda (s c) (declare (ignore s c)) '\{)) ;5/5/83 (set-macro-character #\} #'(lambda (s c) (declare (ignore s c)) '\})) ;5/5/83 (set-macro-character #\^ #'(lambda (s c) (declare (ignore s c)) '\^)) ;5/5/83 ) (defmacro SETSYNTAX (&body z) `() ) ; I'm betting that these can be ignored (defun soarsyntax () ) (defun soarresetsyntax () ) (defmacro selectq (&body z) (setq z (nreverse z)) (cond ((eq 'err (car z)) (cons 'ecase (nreverse (cdr z)))) (t (cons 'case (nreverse z)))) ) (defun soarclearprops (sym) (setf (symbol-plist sym) () ) ) (defun soarmachinetype () (setq *3600-display* nil) (setq *interlisp* nil) ) (defun interlisp-menu (x) (declare (ignore x)) t ) (defun pm-size () (terpri) (printlinec (list *pcount* 'productions (list *real-cnt* '// *virtual-cnt* 'nodes)))) (defun printlinec (x) (mapc (function printlinec*) x)) (defun printlinec* (x) (princ " ") (princ x)) (defun flatc (x) (cond ((numberp x) 3) ((atom x) (length (string x))) (t (+ (flatc (car x)) (flatc (cdr x)) 1)))) (defun flast (list) (last list)) (defun soarlast (list) (car (last list))) (defun soarlistp (thing) (cond ((null thing) NIL) (t (listp thing)))) (defmacro comment (&body z) (declare (ignore z)) t) (defmacro pop-match-elt (x) `(prog (temp) (setq temp (classify-match-elt ,x)) (setq ,x (car temp)) (return (cdr temp)))) (defmacro pop-term (x) `(prog (temp) (setq temp (classify-term ,x)) (setq ,x (car temp)) (return (cdr temp)))) (defun variablep (x) (and (symbolp x) (equalp (soarnthchar x 1) #\<) (not (predicatep x)) (not (eq x '<<)))) ; ****************************** ;;; Do not print a decimal point after integers (setq *nopoint* t) (defun start-soar nil (i-g-v)) (defun nwritn (x) (send standard-output ':read-cursorpos ':character)) ; For version 4.0 (defmacro class (x) `(car ,x)) (defmacro identifier (x) `(cadr ,x)) (defmacro sattribute (x) `(caddr ,x)) (defmacro svalue (x) `(cadddr ,x)) (defmacro call2 (&body z) (list 'ops-call2 (list 'quote z))) (defmacro d (&body z) (list 'ops-d (list 'quote z))) (defmacro sremove (&body z) (list 'ops-sremove (list 'quote z))) (defmacro po (&body z) (list 'ops-po (list 'quote z))) (defmacro pi (&body z) (list 'ops-pi (list 'quote z))) (defmacro pop-goal (&body z) (list 'ops-pop-goal (list 'quote z))) (defmacro ptrace (&body z) (list 'ops-ptrace (list 'quote z))) (defmacro smatches (&body z) (list 'ops-smatches (list 'quote z))) (defmacro spop (&body z) (list 'ops-spop (list 'quote z))) (defmacro swatch (&body z) (list 'ops-swatch (list 'quote z))) (defmacro tabstop (&body z) (list 'ops-tabstop (list 'quote z))) (defmacro unpbreak (&body z) (list 'ops-unpbreak (list 'quote z))) (defmacro write1 (&body z) (list 'ops-write1 (list 'quote z))) (defmacro write2 (&body z) (list 'ops-write2 (list 'quote z))) (defmacro sp (&body z) (list 'ops-sp (list 'quote z))) (defmacro spm (&body z) (list 'ops-spm (list 'quote z))) (defmacro spo (&body z) (list 'ops-spo (list 'quote z))) (defmacro sppwm (&body z) (list 'ops-sppwm (list 'quote z))) (defmacro spr (&body z) (list 'ops-spr (list 'quote z))) (defmacro swm (&body z) (list 'ops-swm (list 'quote z))) ; common lisp ops should fix this with package ;; (defmacro write (&body z) ;; (list 'ops-write (list 'quote z))) (defmacro back-trace (&body z) (list 'ops-back-trace (list 'quote z))) (defmacro learn (&body z) (list 'ops-learn (list 'quote z))) (defun back-trace-conditions (current-goal action-list trace-flag) (prog (production-traces production-trace previously-traced action actions return-list depth) (cond (trace-flag (soarprint " ") (soarprinc "Backtracing to determine conditions") (soarprinc " for goal: ") (soarprint current-goal) (soarprint "Working-memory elements being traced:") (soarmapc #'ppline (p-conds-to-sp (soarmapcar #'clean-up-element action-list))) (soarprint " ") (soarprinc "Productions and conditions traced through:"))) (setq depth 0) (setq return-list nil) (setq actions action-list) (setq previously-traced nil) (setq production-traces (get current-goal 'production-trace)) l0 (cond ((null action-list) (return return-list))) (setq action (pop action-list)) (cond ((eq action 'mark) (setq depth (1- depth)) (go l0)) ((eq action '-) (setq action (pop action-list)) (cond ((and (neq current-goal (get (svalue action) 'in-id-field)) (not (soarmember action return-list))) (trace-new-condition action trace-flag depth '-) (soarpush action return-list) (soarpush '- return-list))) (go l0)) ((and (eq (class action) 'goal-context-info) (or (not (soarmember action *created-list*)) (and *smaller-chunks* (not (soarmemq action actions)) (soarmember action *subgoal-results*)))) (cond ((not (soarmember action return-list)) (trace-new-condition action trace-flag depth nil) (soarpush action return-list))) (go l0)) ((and (neq (class action) 'goal-context-info) (or (not (soarmemq action *created-list*)) (and *smaller-chunks* (not (soarmemq action actions)) (soarmemq action *subgoal-results*)))) (cond ((not (soarmemq action return-list)) (trace-new-condition action trace-flag depth nil) (soarpush action return-list))) (go l0)) ((null action) (go l0))) (setq production-trace (find-back-production action production-traces)) (cond ((null production-trace) (go l0))) (cond ((soarmemq (car production-trace) previously-traced) (go l0)) (t (soarpush (car production-trace) previously-traced))) (setq action-list (append (cadr production-trace) (cons 'mark action-list))) (cond (trace-flag (do-tabto (* 3 depth) (trace-file)) (soarprint (caddr production-trace)))) (setq depth (1+ depth)) (go l0))) (defun broken2 (value) (cond ((or (soarlistp value) (null value)) nil) ((or (soarmemq (get value 'name) *brknames*) (soarmemq value *brknames*) (and *brkrun* (eq (get value 'name) *brkrun*)) (eq value *brkrun*))))) (defun build-sp-cond (avlist extralist) (prog (result) (soarmapc #'(lambda (x) (setq result (append (car x) (append (nreverse (cdr x)) result)))) avlist) (setq result (append (nreverse extralist) result)) (return result))) (defun ops-call2 (z) (prog (sym val) (cond ((not *in-rhs*) (soarwarn "Cannot be called at top level " 'call2) (return nil)) ((not (symbolp (car z))) (soarwarn "Call2: illegal argument " (car z)) (return nil))) ($reset) (eval-args z) (eval (use-result-array)))) (defun cdrmember (element list) (prog nil l0 (cond ((null list) (return nil)) ((equal (cdr element) (cdr (pop list))) (return t))) (go l0))) (defun check-decide nil (or (eq *p-type* 'decide) (soarwarn "Illegal decide in production type " *p-type*))) (defun check-default-make (z) (or (soarmemq *p-type* '(elaborate-once elaborate)) (soarwarn "Illegal make in production type " *p-type*)) (and (null z) (soarwarn "Arguments missing from make action " z)) (check-change& z)) (defun check-remove-ops (z) (soarwarn "Illegal remove in Soar production" *p-type*) (and (null (cdr z)) (soarwarn "Missing arguments for remove " z)) (soarmapc #'check-rhs-ce-var (cdr z))) (defun clean-up-element (element) (clean-up-clause element 'nil)) (defun compare-conditions (elm1 elm2) (cond ((and (null elm1) (null elm2)) t) ((or (null elm1) (null elm2)) nil) ((eq (car elm1) (car elm2)) (compare-conditions (cdr elm1) (cdr elm2))) ((and (eq (get (car elm1) 'tested) 1) (eq (get (car elm2) 'tested) 1)) (soarpush (car elm1) *suspected-duplicates*) (compare-conditions (cdr elm1) (cdr elm2))) (t nil))) (defun compute-choice (choice) (cond ((and (get choice 'name) (get choice 'instance)) (concat (get choice 'name) (soarmapcar #'compute-choice (get choice 'instance)))) ((get choice 'name) (get choice 'name)) ((get choice 'instance) (soarmapcar #'compute-choice (get choice 'instance))) (t choice))) (defun compute-negation-index (matrix) (prog (save-matrix negation-vars negation-list count1 neg-var save-negation-vars negated-conditions condition) (setq negated-conditions nil) (setq negation-vars nil) (setq negation-list nil) (setq save-matrix matrix) l1 (cond (matrix (cond ((equal (car matrix) '-) (pop matrix) (soarpush (remove-condition-trash (car matrix)) negated-conditions) (setq negation-vars (merge-not-time (find-neg-variables (car negated-conditions)) negation-vars)))) (pop matrix) (go l1))) (and (null negated-conditions) (return nil)) (setq count1 0) l3 (cond ((or (null save-matrix) (eq condition '-->)) (return (list negated-conditions negation-list)))) (setq condition (pop save-matrix)) (cond ((eq condition '-) (setq save-matrix (cdr save-matrix)) (go l3))) (setq save-negation-vars negation-vars) (setq negation-vars nil) l4 (cond ((null save-negation-vars) (setq count1 (1+ count1)) (go l3))) (setq neg-var (pop save-negation-vars)) (cond ((eq condition '-->) (soarpush neg-var negation-vars)) ((soarmemq neg-var condition) (soarpush (list neg-var count1 (find-position neg-var condition)) negation-list)) (t (soarpush neg-var negation-vars))) (go l4))) (defun condition-trace (x) (trace-condition-action x 'condition)) (defun conv-input-wme (input) (cond ((numberp input) (get-wm (list input))) ((and (soarlistp input) (neq (car input) 'preference)) (soarmapconc #'sswm (sp-info-expand nil input nil))) ((soarlistp input) (sswm input)) (t (sswm (append '(^ identifier) (list input)))))) (defun create-goal-info (data-matched goal-id) (setq *data-matched* data-matched) (setq *first-action* t)) (defun created (g) (soarmapc #'print (get g 'created)) t) (defun ops-d (dc) (cond ((atom dc) (run)) (t (eval (list 'run (car dc) 'd))))) (defun delprop (name attribute value) (soarputprop name (dremove value (get name attribute)) attribute)) (defun eliminate-trailing-nil (wme) (prog nil (cond ((atom wme) (return wme)) ((soarlast wme) (return wme))) (setq wme (dreverse wme)) l1 (cond ((car wme) (return (dreverse wme)))) (setq wme (cdr wme)) (go l1))) (defun excise-chunks nil (prog (chunks) (setq chunks (append *chunks* nil)) (soarmapc #'(lambda (x) (setq *tracep-list* (dremove x *tracep-list*))) chunks) (eval (cons 'excise chunks)))) (defun fill-up (wme) (fill-up-c wme 'new) (sendto 'new (list wme) 'left (list *new-root*))) (defun fill-up-c (wme flag) (prog (dp) (setq *alpha-flag-part* flag) (setq *alpha-data-part* (list wme)) (setq dp wme) (setq *c1* (car dp)) (setq dp (cdr dp)) (setq *c2* (car dp)) (setq dp (cdr dp)) (setq *c3* (car dp)) (setq dp (cdr dp)) (setq *c4* (car dp)) (setq dp (cdr dp)) (setq *c5* (car dp)) (setq dp (cdr dp)) (setq *c6* (car dp)) (setq dp (cdr dp)) (setq *c7* (car dp)) (setq dp (cdr dp)) (setq *c8* (car dp)) (setq dp (cdr dp)) (setq *c9* (car dp)) (setq dp (cdr dp)) (setq *c10* (car dp)) (setq dp (cdr dp)) (setq *c11* (car dp)) (setq dp (cdr dp)) (setq *c12* (car dp)) (setq dp (cdr dp)) (setq *c13* (car dp)) (setq dp (cdr dp)) (setq *c14* (car dp)) (setq dp (cdr dp)) (setq *c15* (car dp)) (setq dp (cdr dp)) (setq *c16* (car dp)))) (defun fill-up-wm (wm) (soarmapc #'fill-up wm)) (defun fill-up2 (wme) (fill-up-c (car wme) 'new) (sendto 'new (list (car wme)) 'left (list *new-root*))) (defun find-acceptable-preference (preferences id) (prog (preference) l0 (cond ((null preferences) (return nil))) (setq preference (pop preferences)) (cond ((and (eq 'preference (class preference)) (eq id (identifier preference)) (eq 'acceptable (svalue preference))) (return preference))) (go l0))) (defun find-action-sets (actions subgoal) (prog (return-list new-action-list current-closure moved-action action possible-actions) (setq return-list nil) l0 (and (null actions) (return (nreverse return-list))) (setq action (pop actions)) (setq new-action-list (list action)) (setq current-closure (find-unbound-symbols action)) (cond ((null current-closure) (soarpush (nreverse new-action-list) return-list) (go l0))) l2 (setq moved-action nil) (setq possible-actions actions) (setq actions nil) l1 (cond ((and (null possible-actions) moved-action) (go l2)) ((null possible-actions) (soarpush (nreverse new-action-list) return-list) (go l0))) (setq action (pop possible-actions)) (cond ((intrq (cons (cadr action) (cdddr action)) current-closure) (setq current-closure (append (find-unbound-symbols action) current-closure)) (soarpush action new-action-list) (setq moved-action t)) ((and *smaller-chunks* (neq (car action) 'preference) (intrq (list (cadr action)) current-closure)) (setq current-closure (append (find-unbound-symbols action) current-closure)) (soarpush action new-action-list) (setq moved-action t)) ((and *smaller-chunks* (eq (car action) 'preference) (intrq (list (cddddr action)) current-closure)) (setq current-closure (append (find-unbound-symbols action) current-closure)) (soarpush action new-action-list) (setq moved-action t)) (t (soarpush action actions))) (go l1))) (defun find-back-production (action traces) (cdr (cond ((eq (class action) 'goal-context-info) (soarassoc action traces)) (t (soarassq action traces))))) (defun find-max-goal-depth (goal-list) (prog (max-depth max-depth-goal goal-depth) (setq max-depth -1) (setq max-depth-goal nil) l0 (cond ((null goal-list) (return max-depth-goal))) (setq goal-depth (get (cadar goal-list) 'goal-depth)) (cond ((and goal-depth (< max-depth goal-depth)) (setq max-depth goal-depth) (setq max-depth-goal (cadar goal-list)))) (pop goal-list) (go l0))) (defun find-neg-variables (condition) (prog (return-list) (setq return-list nil) l1 (cond ((null condition) (return return-list)) ((variablep (car condition)) (soarpush (car condition) return-list))) (pop condition) (go l1))) (defun find-position (var condition) (prog (attribute) l1 (cond ((or (null condition) (eq var (car condition))) (return (1- (literal-binding-of attribute)))) ((and (car condition) (predicatep (car condition))) (setq condition (cddr condition))) ((and (car condition) (eq (car condition) '^)) (setq attribute (cadr condition)) (setq condition (cddr condition))) ((and (car condition) (soarmemq (car condition) '({ }))) (pop condition)) (t (pop condition))) (go l1))) (defun find-selected-result (choice results) (prog (result) (cond ((numberp choice) (cond ((or (< choice 1) (> choice (length results))) (return nil))) (return (soarnth (1- choice) results)))) l1 (setq result (pop results)) (cond ((test-selected-result choice result) (and (null *select-equal*) (setq *select-equal* *default-user-select*)) (return result)) ((null results) (return nil))) (go l1))) (defun find-small-action-sets (actions subgoal) (prog (action action-pi pi-action-list return-list rest-pi-list) (setq pi-action-list nil) l1 (cond ((null actions) (return (soarmapcar #'cdr pi-action-list)))) (setq action (pop actions)) (setq action-pi (car (find-back-production action (get subgoal 'production-trace)))) (cond ((setq rest-pi-list (soarassq action-pi pi-action-list)) (rplacd rest-pi-list (cons action (cdr rest-pi-list)))) (t (soarpush (list action-pi action) pi-action-list))) (go l1))) ;** Chris Fedor 11/26/85 ;** added (not (numberp value)) test to avoid doing get on a number (defun find-subgoal-nonresults (subgoal supergoal created-list) (prog (change-flag action id nonresult-list goal value) (setq *subgoal-results* nil) l1 (setq change-flag nil) (setq nonresult-list nil) l2 (cond ((and (null created-list) (null change-flag)) (setq *subgoal-results* (nreverse *subgoal-results*)) (return nonresult-list)) ((null created-list) (setq created-list (nreverse nonresult-list)) (go l1))) (setq action (pop created-list)) (setq id (identifier action)) (setq goal (get id 'in-id-field)) (cond ((or (and (eq (car action) 'preference) (closure-preference action subgoal)) (and (neq (car action) 'preference) (neq goal subgoal))) (setq change-flag t) (soarpush action *subgoal-results*) (setq value (svalue action)) (cond ((and (eq (car action) 'preference) (eq goal subgoal)) (soarpush id *unbound-action-ids*) (and supergoal (soarputprop id supergoal 'in-id-field))) ((and (neq (car action) 'preference) (not (numberp value)) (eq (get value 'in-id-field) subgoal)) (and supergoal (soarputprop value supergoal 'in-id-field)) (soarpush value *unbound-action-ids*))) (and supergoal (addprop supergoal 'created action))) (t (soarpush action nonresult-list))) (go l2))) (defun find-variables (list) (cond ((null list) nil) ((variablep (car list)) (cons (car list) (find-variables (cdr list)))) (t (find-variables (cdr list))))) (defun find-reject-preferences (preferences) (prog (preference return-list) (setq return-list nil) l0 (cond ((null preferences) (return return-list))) (setq preference (pop preferences)) (cond ((and (eq 'preference (class preference)) (eq 'reject (svalue preference))) (soarpush preference return-list))) (go l0))) (defun find-unbound-symbols (action) (prog (return-list) (setq return-list nil) l1 (cond ((null action) (return return-list)) ((and (get (car action) 'in-id-field) (soarmemq (car action) *unbound-action-ids*)) (soarpush (car action) return-list))) (pop action) (go l1))) (defun flatten (l) (soarmapconc #'(lambda (item) (cond ((atom item) (list item)) (t (flatten item)))) l)) (defun gensyminit nil (soarmapc #'soarclearprops *used-gensym-list*) (soarmapc #'move-to-free-gensym-list *used-gensym-list*) (setq *used-gensym-list* nil)) (defun handle-back-trace-actions (action-list old-context prior-context new-context subgoaled) (prog (duplicate-list copy-list return-value closure condition-list negation-list wme-list) (clear-var-list) (setq wme-list (back-trace-conditions (get-current old-context 'goal) action-list *ltrace*)) (setq *p-name* (get-current old-context 'goal)) (setq *first-action* t) (soarmapc #'(lambda (x) (save-production-trace x wme-list (get-current new-context 'goal))) action-list) (cond ((and (not *always-learn*) (or subgoaled (get-context-subgoaled old-context))) (return t)) ((or (not *learning*) (soarmemq (get (get-current old-context 'problem-space) 'name) *chunk-free-problem-spaces*) (not (test-context prior-context))) (return nil))) (setq closure (find-closure wme-list)) (soarmapc #'build-variable-list closure) (setq *action-closure* (find-action-closure action-list)) (setq condition-list (soarmapcar #'(lambda (x) (clean-up-clause x 'condition)) wme-list)) (setq action-list (soarmapcar #'clean-up-action action-list)) (setq condition-list (process-negations condition-list)) (setq negation-list (cdr condition-list)) (setq condition-list (build-terse (soarcarsort (car condition-list)))) (cond ((test-chunk-for-content condition-list) (and *ltrace* (soarmapc #'ppline (p-conds-to-sp condition-list))) (return nil))) (setq duplicate-list (compactify-conditions (append condition-list negation-list) action-list)) (setq copy-list (bind-it *action-list*)) (setq *action-list* (rebind-action-ids *action-list* copy-list)) (setq *copy-action-list* *action-list*) (setq return-value (build-a-production *condition-list* *action-list* wme-list)) (and duplicate-list (soarmapc #'build-copies duplicate-list)) (return return-value))) (defun init-literalizes nil (literalize preference object role value reference goal problem-space state operator) (literalize goal-context-info identifier attribute value) (literalize space-info identifier attribute value) (literalize state-info identifier attribute value) (literalize op-info identifier attribute value) (literalize eval-info identifier attribute value) (literalize desired-info identifier attribute value) (literalize info identifier attribute value)) (defun init-soar nil (setq *in-rhs* nil) (sremove) (setq *init-wm* nil) (setq *conflict-set* nil) (setq *wmpart-list* nil) (setq *p-name* nil) (setq *phase* 'elaborate) (setq *prod-count* (setq *decide-count* (setq *cycle-count* (setq *action-count* 0)))) (setq *total-token* (setq *max-token* (setq *current-token* 0))) (setq *first-action* nil) (gensyminit) (setq *current-production-trace* 'cpt) (soarmapc #'soarclearprops *user-ids*) (setq *user-ids* nil) (and *3600-display* (clear-soar2-window)) (setq *total-cs* (setq *max-cs* 0)) (setq *total-wm* (setq *max-wm* (setq *current-wm* 0))) (setq *elapsed-time* 0) (setq *trace-number* 0) (setq *context* (list (soargensym 'goal) 'undecided 'undecided 'undecided 1 'nil 'nil 'nil 'nil 'nil 0)) (setq *context-stack* (list *context*)) (setq *data-matched* nil)) (defun init-wm nil (prog (cg cp cs co) (cond ((not *init-wm*) (setq *phase* 'decide) (setq cg (get-current *context* 'goal)) (setq cp (get-current *context* 'problem-space)) (setq cs (get-current *context* 'state)) (setq co (get-current *context* 'operator)) (soarputprop cg 1 'goal-depth) (and *learning* (learn)) (make-info 'goal-context-info cg 'problem-space cp) (trace-object 'goal cg 0) (trace-object 'problem-space cp 0) (make-info 'goal-context-info cg 'state cs) (trace-object 'state cs 0) (make-info 'goal-context-info cg 'operator co) (trace-object 'operator co 0) (setq *init-wm* t) (setq *phase* 'elaborate))))) (defun intrq (x y) (cond ((atom x) nil) ((soarmemq (car x) y) (cons (car x) (intrq (cdr x) y))) (t (intrq (cdr x) y)))) (defun last-chunk nil (eval (cons 'spm (list (car *chunks*))))) (defun list-chunks nil (eval (cons 'spm (reverse *chunks*)))) (defun make-new-root (pname) (link-new-node (list '&priv nil pname))) (defun make-nil-list (list-length) (prog (nil-list) (setq nil-list '(nil)) l1 (cond ((eq list-length (length nil-list)) (return nil-list))) (soarpush 'nil nil-list) (go l1))) (defun mark-in-id (wme) (prog (id att value port) (setq port (trace-file)) (setq id (identifier wme)) (setq att (sattribute wme)) (and (not id) (return nil)) (cond ((and (neq *phase* 'decide) (eq 'goal-context-info (class wme)) (soarmemq att '(problem-space state operator))) (soarwarn "Illegal attempt to modify context" wme) (return t)) ((eq *phase* 'decide) (setq *current-goal* (get-current *context* 'goal))) ((and (not *current-goal*) (setq *current-goal* 'undecided))) ((and *first-action* (eq (get *p-name* 'type) 'elaborate-once)) (and (eq (cdr (soarassq *p-name* *already-fired*)) *current-goal*) (return t)) (soarpush (cons *p-name* *current-goal*) *already-fired*))) (cond ((and (not (get id 'gensymed)) (not (soarmemq id *user-ids*))) (soarpush id *user-ids*))) (cond ((not (get id 'in-id-field)) (soarputprop id *current-goal* 'in-id-field))) (setq value (svalue wme)) (cond ((eq att 'name) (soarputprop id value 'name)) ((soarmember (list (class wme) att) *instance-attributes*) (addprop id 'instance value))) (cond ((not *never-learn*) (save-production-trace wme (reverse *data-matched*) *current-goal*))) (cond (*first-action* (cond ((and *ptrace* *ttrace* (not *wtrace*) (trace-problem-space?)) (soarprinc "-->"))) (setq *first-remove* t) (setq *first-action* nil))) (addprop *current-goal* 'created wme) (return nil))) (defun match-update (wme) (fill-up-c (car wme) 'new) (sendto 'new (list (car wme)) 'left (list *new-root*))) (defun mem-length (mem) (prog (n) (setq n 0) (soarmapc #'(lambda (ci) (cond ((soarlistp ci) (setq n (+ n 1))))) mem) (return n))) (defun merge-not-time (lista listb) (prog (elm) (and (null lista) (return listb)) (setq elm (car lista)) (cond ((null listb) (return lista)) ((numberp elm) (return (merge-not-time (cdr lista) listb))) ((soarmemq elm listb) (return (merge-not-time (cdr lista) listb))) (t (return (cons elm (merge-not-time (cdr lista) listb))))))) (defun most-recent-subgoal (context-stack) (cond ((null (cdr context-stack)) (caar context-stack)) (t (most-recent-subgoal (cadr context-stack))))) (defun move-to-free-gensym-list (symbol) (prog (char sym-list) (setq char (soarnthchar symbol 1)) (setq sym-list (soarassq char *free-gensym-list*)) (cond ((null sym-list) (setq *free-gensym-list* (append *free-gensym-list* (list (list char symbol))))) (t (rplacd sym-list (append (list symbol) (cdr sym-list))))))) (defun multi-attribute (x) (prog (class) (cond ((soarassq (car x) *sp-classes*) (setq class (cdr (soarassq (car x) *sp-classes*)))) (t (setq class (soarpack2 (car x) '-info)) (soarpush (cons (car x) class) *sp-classes*))) (cond ((not (soarmemq class *save-class-list*)) (soarpush class *save-class-list*) (soarputprop class (get 'state-info 'ppdat) 'ppdat))) (setq x (cdr x)) (cond ((and (cdr x) (numberp (cadr x)) (or (> (cadr x) 99) (< (cadr x) 1))) (soarwarn "Illegal multi-attribute value" (cadr x)) (setq x (list (car x))))) (soarpush (cons class x) *multi-attribute*))) (defun multi-attributes (x) (soarmapc #'multi-attribute x)) (defun new-variables (condition stack) (prog (first elm) (setq first (car stack)) l1 (setq elm (pop condition)) (cond ((null condition) (return stack)) ((and (variablep elm) (neq first elm)) (soarpush elm stack))) (go l1))) (defun new-variable-list (condition list) (prog (elm) l1 (setq condition (cdr condition)) (setq elm (car condition)) (cond ((null condition) (return list)) ((and (variablep elm) (not (soarmemq elm list))) (soarpush elm list))) (go l1))) (defun ops-sremove (z) (cond ((equal z '*) (process-changes nil (get-wm nil))) (t (process-changes nil (get-wm z))))) (defun sswm (avlist) (cond ((and (cdddr avlist) (variablep (cadddr avlist))) (rplacd avlist (cddddr avlist)))) (cond ((not (conv-to-attr-nums avlist nil)) nil) (t (mapwm #'sswm2) (prog2 nil *wm* (setq *wm* nil))))) (defun sswm2 (elm-tag) (cond ((filter (car elm-tag)) (soarpush (car elm-tag) *wm*)))) (defun pgs nil (pgs-frame *context-stack* 1 nil nil nil) (soarprintc "Decision cycle ") (soarprinc *decide-count*) (terpri (trace-file))) (defun pgs-frame (context-stack depth difficulty results second-time) (prog (slots slot id context difficulty2 super-op result port) (setq port (trace-file)) (setq context (pop context-stack)) (cond ((null context) (return nil)) (second-time (terpri (trace-file)))) (setq super-op (get-context-super-operator context)) (setq difficulty2 (list (get-context-difficulty context) (get-context-slot context))) (setq result (get-context-results context)) (setq slots '(g p s o)) l2 (cond (slots (setq id (pop context)) (setq slot (pop slots)) (cond ((neq id 'undecided) (terpri port) (cond (*subgoal-tabs* (do-tabto (+ 2 (* depth 3)) port)) (t (do-tabto 5 port) (soarprinc3 "(" (1- depth) ")") (do-tabto 11 port))) (soarprinc2 slot ": ") (print-id id) (setq difficulty nil))) (go l2))) (setq second-time nil) (soarmapc #'(lambda (x) (pgs-frame x (1+ depth) difficulty2 result second-time) (setq second-time t)) context-stack))) (defun ops-po (object) (print-object (car object) (cadr object))) (defun ops-pi (z) (print-partial-instantiation (car z) (cond ((cdr z) (cadr z)) (t 1)))) (defun ppi3 (p i nodes ce part) (prog (saved-mems n smatch-flg) (cond ((null nodes) (setq n 0) (soarmapc #'(lambda (ci) (cond ((eq (car ci) p) (setq n (+ n 1)) (cond ((equal n i) (soarmapc #'(lambda (wme) (eval (list 'wm (creation-time wme)))) (reverse (cdr ci))) (terpri (trace-file))))))) *conflict-set*) (terpri (trace-file)) (return ce)) ((null (setq saved-mems (find-left-mem (car nodes)))) (return nil)) ((not (setq smatch-flg (ppi3 p i (cdr nodes) (1+ ce) (cons ce part)))) (soarmapc #'(lambda (ci) (eval (list 'wm (creation-time ci)))) (reverse (soarnth (1- i) saved-mems))) (terpri (trace-file)) (return ce))) (return smatch-flg))) (defun ops-pop-goal (goals) (cond ((null goals) (soarmapc #'(lambda (x) (pop-subgoals x (most-recent-subgoal *context-stack*) *context-stack* (car *context-stack*))) (cdr *context-stack*))) (t (soarmapc #'(lambda (y) (soarmapc #'(lambda (x) (pop-subgoals x y *context-stack* (car *context-stack*))) (cdr *context-stack*))) goals))) nil) (defun pop-subgoals (stack g prior-stack prior-context) (cond (stack (cond ((eq (caar stack) g) (remove-subgoal-objects stack) (rplacd prior-stack nil) (rplaca (soarnthcdr 4 prior-context) 0) (rplaca (soarnthcdr 5 prior-context) nil)) (t (soarmapc #'(lambda (x) (pop-subgoals x g stack (car stack))) (cdr stack))))))) (defun print-choice (choice) (print-id choice) (soarprint " ")) (defun print-id (id) (soarprinc2 id " ") (cond ((and id (atom id) (neq id 'undecided)) (and (get id 'name) (soarprinc (get id 'name))) (setq *print-attribute-list* (list id)) (print-instance id) (setq *print-attribute-list* nil)))) (defun print-instance (id) (prog (flag) (cond ((get id 'instance) (setq flag nil) (soarprinc "(") (soarmapc #'(lambda (object) (and flag (soarprinc " ")) (setq flag t) (cond ((get object 'name) (soarprinc (get object 'name)) (cond ((not (soarmemq object *print-attribute-list*)) (soarpush object *print-attribute-list*) (print-instance object)))) (t (soarprinc object) (cond ((not (soarmemq object *print-attribute-list*)) (soarpush object *print-attribute-list*) (print-instance object)))))) (get id 'instance)) (soarprinc ")"))))) (defun print-instantiation (p i) (prog (n) (setq n 0) (soarmapc #'(lambda (inst) (cond ((eq (car inst) p) (setq n (1+ n)) (cond ((equal n i) (soarmapc #'(lambda (wme) (eval (list 'wm (creation-time wme)))) (reverse (cdr inst))) (terpri (trace-file))))))) *conflict-set*))) (defun print-partial-instantiation (p i) (ppi3 p i (get p 'backpointers) 2 (ncons 1))) (defun printline (x) (soarmapc #'soarprinc x) (terpri (trace-file))) (defun print-object (object depth) (cond ((and *3600-display*) (draw-current-contents object)) (t (eval (append '(ppwm ^ identifier) (list object)))))) (defun print-status nil (soarprintc "Learn status: ") (cond (*learning* (soarprinc "on ")) (*never-learn* (soarprinc "never ")) (t (soarprinc "off "))) (cond (*always-learn* (soarprinc "always ")) (t (soarprinc "bottom-up "))) (cond ((eq *print-learn* 0) (soarprinc "print ")) (*print-learn* (soarprinc "full-print ")) (t (soarprinc "noprint "))) (cond ((and *ltrace* *tracep*) (soarprint "full-trace ")) (*tracep* (soarprint "trace ")) (t (soarprint "notrace "))) t) (defun process-instance (instance) (prog nil (setq *first-action* t) (accum-stats) (eval-rhs (car instance) (cdr instance)) (check-limits) (and (broken (car instance)) (setq *break-flag* t)))) (defun process-negations (conditions) (prog (return-conditions element negations) (setq negations nil) l2 (cond ((null conditions) (setq negations (variablize-negations negations)) (and negations (return (cons (nreverse return-conditions) (nreverse (tersify-negations negations))))) (return (list (nreverse return-conditions)))) ((eq (car conditions) '-) (pop conditions) (soarpush (pop conditions) negations)) (t (soarpush (pop conditions) return-conditions))) (go l2))) (defun ops-ptrace (arg) (cond ((atom arg) *tracep-list*) (t (setq *tracep-list* (append *tracep-list* (soarmapcar #'(lambda (x) (cond ((or (numberp x) (soarlistp x)) (car (conv-input-wme x))) (t x))) arg)))))) (defun remove-condition-attributes (condition) ($reset) (cond ((neq (cadr condition) '^) (eval-args (append (cons (car condition) '(^ identifier)) (cdr condition)))) (t (eval-args condition))) (use-result-array)) (defun remove-condition-trash (condition) (prog (return-condition pand-flag disjunction-flag) (setq return-condition nil) (setq pand-flag nil) (setq disjunction-flag nil) l1 (cond ((null condition) (return (nreverse return-condition))) ((eq (car condition) '<<) (pop condition) (setq disjunction-flag t)) ((eq (car condition) '>>) (pop condition) (setq disjunction-flag nil)) (disjunction-flag (pop condition)) ((eq (car condition) '{) (pop condition) (setq pand-flag t)) ((eq (car condition) '}) (pop condition) (and pand-flag (soarpush (soargenvar 'z) return-condition)) (setq pand-flag nil)) ((predicatep (car condition)) (setq condition (cddr condition))) (t (soarpush (pop condition) return-condition) (setq pand-flag nil))) (go l1))) (defun remove-current (goal slot old-value new-value) (prog nil (cond ((soarlistp old-value) (soarmapc #'(lambda (x) (remove-from-wm (list 'goal-context-info goal slot x))) old-value)) (t (remove-from-wm (list 'goal-context-info goal slot old-value)))) (return (cond ((soarlistp new-value) (soarmapcar #'(lambda (x) (list 'goal-context-info goal slot x)) new-value)) (t (list (list 'goal-context-info goal slot new-value))))))) (defun remove-subgoal-objects (stack) (cond (stack (soarmapc #'remove-subgoal-objects (cdr stack)) (soarmapc #'remove-from-wm (get (caar stack) 'created)) (soarclearprops (caar stack))))) (defun restart-soar nil (prog (pnames) (setq pnames (append *pnames* nil)) (eval (cons 'excise pnames)) (soarmapc #'soarclearprops (append *save-class-list* *class-list* *used-gensym-list*)) (i-g-v))) (defun save-production-trace (wme data-matched current-goal) (cond (data-matched (cond ((and *first-action* data-matched) (setq *current-production-trace* (list (setq *trace-number* (1+ *trace-number*)) data-matched *p-name*)))) (addprop current-goal 'production-trace (cons wme *current-production-trace*)) wme))) (defun showload (file) (prog (in nextexpr) (setq in (openfile file 'input)) l1 (setq nextexpr (read in)) (cond ((eq nextexpr 'stop) (return))) (soarprinc "----> ") (soarprinc nextexpr) (terpri (trace-file)) (soarprinc (eval nextexpr)) (terpri (trace-file)) (go l1))) (defun ops-smatches (rule-list) (soarmapc #'smatches2 rule-list) (terpri (trace-file))) (defun smatches2 (p) (cond ((atom p) (terpri (trace-file)) (spprule p (smatches3 p (get p 'backpointers) 2 (ncons 1)))))) (defun smatches3 (p nodes ce part) (prog (saved-mems n smatch-flg temp-flg port) (setq port (trace-file)) (cond ((null nodes) (terpri (trace-file)) (cond ((not (soarassq p *conflict-set*)) (return nil))) (soarprinc3 "** MATCHES FOR " (reverse part) " ** ") (setq n 0) (soarmapc #'(lambda (ci) (cond ((eq (car ci) p) (swrite-elms (cdr ci)) (setq n (+ n 1))))) *conflict-set*) (terpri (trace-file)) (return (ncons n))) (t (setq saved-mems (find-left-mem (car nodes))) (cond ((null saved-mems) (return nil))) (setq temp-flg (smatches3 p (cdr nodes) (1+ ce) (cons ce part))) (setq smatch-flg (cons (mem-length saved-mems) (cons (mem-length (find-right-mem (car nodes))) temp-flg))) (cond ((not temp-flg) (terpri (trace-file)) (soarprinc3 "** MATCHES FOR " (reverse part) " ** ") (soarmapc #'swrite-elms saved-mems) (terpri (trace-file)) (soarprinc3 "** MATCHES FOR " ce " ** ") (terpri (trace-file)) (soarmapc #'(lambda (x) (cond ((soarlistp x) (soarmapc #'write-elms2 (reverse x))))) (find-right-mem (car nodes))) (terpri (trace-file)) (return smatch-flg))) (return smatch-flg))))) (defun soarprinc (warning) (princ warning (trace-file))) (defun soarprinc1 (x1 x2) (princ x1 (trace-file)) (princ x2 (trace-file))) (defun soarprinc2 (x1 x2) (princ x1 (trace-file)) (princ x2 (trace-file))) (defun soarprinc3 (x1 x2 x3) (princ x1 (trace-file)) (princ x2 (trace-file)) (princ x3 (trace-file))) (defun soarprint (warning) (prog2 nil (princ warning (trace-file)) (terpri (trace-file)))) (defun soarprintc (warning) (terpri (trace-file)) (princ warning (trace-file))) (defun soarwarn (warning warning2) (prog (port) (and (null *warning*) (return warning2)) (setq port (trace-file)) (terpri port) (princ "Warning: " port) (and *p-name* (princ *p-name*)) (princ ".." port) (princ warning port) (princ " " port) (princ warning2 port) (return warning2))) (defun ops-spop (object) (setq *indent* 0) (setq *print-spo-list* nil) (cond ((or (null object) (numberp (car object)))) ((not (numberp (soarlast object))) (terpri (trace-file)) (spo1 (car object) *spo-default-depth* t) (eval (cons 'spop (cdr object)))) (t (terpri (trace-file)) (spo1 (car object) (soarlast object) t) (eval (cons 'spop (cdr object))))) (setq *print-spo-list* nil)) (defun spprule (name cond-nums) (prog (matrix next lab cond-flg port) (and (not (symbolp name)) (return nil)) (setq matrix (get name 'production)) (and (null matrix) (return nil)) (setq port (trace-file)) (setq cond-flg nil) (terpri port) (soarprinc3 "(" 'p " ") (soarprinc3 name " " (get name 'type)) top (and (atom matrix) (go fin)) (setq next (car matrix)) (setq matrix (cdr matrix)) (setq lab nil) (terpri port) (cond ((and cond-nums (> (car cond-nums) 0)) (princ (car cond-nums) port) (do-tabto 5 (trace-file)) (setq cond-nums (cddr cond-nums))) ((eq next '-->) (princ " " port) (setq cond-flg t)) (cond-flg (princ " " port)) (t (princ ">>>>" port) (setq cond-flg t))) (cond ((eq next '-) (princ "- " port) (setq next (car matrix)) (setq matrix (cdr matrix))) ((neq next '-->) (princ " " port))) (ppline next) (cond (lab (soarprinc3 " " lab '}))) (go top) fin (soarprint ")"))) (defun swrite-elms (wme-or-count) (cond ((soarlistp wme-or-count) (terpri (trace-file)) (soarmapc #'write-elms2 (reverse wme-or-count))))) (defun soargenpname (x) (prog (sym-list sym) (cond (*free-pname-list* (setq sym (pop *free-pname-list*))) (t (setq sym (soargensymbol (soarnthchar x 1))))) (soarputprop sym t 'gensymed) (return sym))) (defun soargensym (x) (prog (sym-list charx sym) (setq charx (soarnthchar x 1)) (setq sym-list (soarassq charx *free-gensym-list*)) (cond ((null (cdr sym-list)) (setq sym (soargensymbol charx))) (t (setq sym (cadr sym-list)) (rplacd sym-list (cddr sym-list)))) (soarputprop sym t 'gensymed) (soarpush sym *used-gensym-list*) (return sym))) (defun soargenvar (id) (prog (first-char gen-number new-var) (setq first-char (soarnthchar id 1)) (cond ((soarmemq first-char *used-char-list*) (setq gen-number (get first-char 'var-count))) (t (soarpush first-char *used-char-list*) (setq gen-number 1))) (setq new-var (soarpack '< first-char gen-number '>)) (soarpush new-var *used-var-list*) (soarputprop first-char (1+ gen-number) 'var-count) (return new-var))) (defun ops-swatch (z) (cond ((equal z '(0)) (setq *gtrace* nil) (setq *strace* nil) (setq *dtrace* nil) 0) ((equal z '(1)) (setq *gtrace* t) (setq *strace* nil) (setq *dtrace* nil) 1) ((equal z '(2)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* nil) 2) ((equal z '(3)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* t) 3) ((and (atom z) (null *gtrace*)) 0) ((and (atom z) (null *strace*)) 1) ((and (atom z) (null *dtrace*)) 2) ((atom z) 3) (t 'what?))) (defun t-in-list? (x) (soarmemq 't (flatten x))) (defun ops-tabstop (z) (prog (val) (cond ((not *in-rhs*) (soarwarn "TABSTOP can not be called at the top level" " ") (return nil)) ((neq (length z) 1) (soarwarn "Wrong number of arguments for Tabstop:" z) (return nil)) ((not (variablep (car z))) (soarwarn "Illegal argument for Tabstop:" (car z)) (return nil)) ((equalp (length z) 1) (setq val (+ 3 (* (get-context-depth *context*) 3))))) (make-var-bind (car z) val))) (defun test-connected-actions (actions) (prog (changed-flag action save-action saved-actions found-variable) (setq changed-flag t) (setq saved-actions (cdr actions)) l1 (setq actions saved-actions) (setq saved-actions nil) (cond ((null actions) (return)) ((null changed-flag) (soarwarn "Unconnected actions in production" (p-to-sp actions)) (return))) (setq changed-flag nil) l2 (cond ((null actions) (go l1))) (setq action (pop actions)) (cond ((neq (car action) 'make) (go l2))) (setq save-action action) (setq found-variable nil) l3 (cond ((and (null action) found-variable) (soarpush save-action saved-actions) (go l2)) ((null action) (go l2)) ((soarmemq (car action) *condition-vars*) (setq *condition-vars* (append *condition-vars* (find-variables save-action))) (setq changed-flag t) (setq found-variable t) (go l2)) ((variablep (car action)) (setq found-variable t))) (pop action) (go l3))) (defun test-preference-field (field subgoal) (or (null field) (eq field 'undecided) (neq (get field 'in-id-field) subgoal))) (defun test-selected-result (choice result) (or (eq choice result) (eq choice (get result 'name)) (and (soarmemq choice (get result 'instance)) t) (and (get result 'instance) (soarmemq t (flatten (soarmapcar #'(lambda (x) (test-selected-result choice x)) (get result 'instance)))) t))) (defun test-subset (lista listb) (cond ((null lista) t) ((soarmemq (car lista) listb) (test-subset (cdr lista) listb)) (t nil))) (defun teqnilb (x y) (or (eq x y) (null x))) (defun trace-attribute (x) (prog (class) (cond ((soarassq (car x) *sp-classes*) (soarpush (cons (cdr (soarassq (car x) *sp-classes*)) (cdr x)) *instance-attributes*)) (t (setq class (soarpack2 (car x) '-info)) (soarpush (cons (car x) class) *sp-classes*) (soarpush class *save-class-list*) (soarputprop class (get 'state-info 'ppdat) 'ppdat) (soarpush (cons class (cdr x)) *instance-attributes*))))) (defun trace-attributes (x) (soarmapc #'trace-attribute x)) (defun trace-condition-action (wme flag) (cond ((null *tracep-list*)) ((or (soarmember wme *tracep-list*) (soarmemq (identifier wme) *tracep-list*) (soarmemq (get (identifier wme) 'name) *tracep-list*)) (soarprintc *p-name*) (cond ((eq flag 'action) (soarprinc ": -->")) (t (soarprinc ": matches "))) (ppline (car (p-conds-to-sp (list (clean-up-clause wme 'action)))))))) (defun trace-ids (item) (print-id item)) (defun trace-new-condition (action trace-flag depth negation) (cond ((and trace-flag negation) (do-tabto (* 3 depth) (trace-file)) (ppline (cons negation (car (p-conds-to-sp (list (clean-up-element action)))))) (soarprint " ")) (trace-flag (do-tabto (* 3 depth) (trace-file)) (ppline (car (p-conds-to-sp (list (clean-up-element action))))) (soarprint " ")))) (defun trace-object (type id depth) (cond ((or (and (not *gtrace*) (not *otrace*)) (not (trace-problem-space?)) (eq id 'undecided))) ((and *otrace* id) (cond ((and *3600-display* *gtrace*) (draw-current-object type id depth))) (soarprintc *decide-count*) (cond ((and *subgoal-tabs* (neq depth 0) (eq type 'goal)) (do-tabto (+ 2 (* depth 3)) (trace-file)) (princ '==> (trace-file))) (*subgoal-tabs* (do-tabto (+ 5 (* depth 3)) (trace-file))) (t (do-tabto 5 (trace-file)) (soarprinc3 "(" depth ")") (do-tabto 11 (trace-file)))) (soarprinc2 (cond ((eq type 'goal) 'g) ((eq type 'problem-space) 'p) ((eq type 'state) 's) ((eq type 'operator) 'o)) ": ") (print-id id)))) (defun trace-problem-space? nil (not (soarmemq (get (get-current *context* 'problem-space) 'name) *watch-free-problem-spaces*))) (defun ops-unpbreak (z) (cond ((atom z) (setq *brkpts* nil) (setq *brknames* nil) nil) (t (soarmapc #'unpbreak2 z) nil))) (defun unpbreak2 (rule) (prog (type blist) (cond ((or (not (symbolp rule)) (soarlistp rule)) (soarwarn "Illegal argument:" rule)) ((soarmemq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)) rule) ((soarmemq rule *brknames*) (setq *brknames* (rematm rule *brknames*)) rule) (t nil)))) (defun unptrace nil (setq *tracep-list* nil)) (defun untest (element) (cond ((and element (variablep (caddr element))) (soarputprop (caddr element) (1- (get (caddr element) 'tested)) 'tested) (untest (cdddr element))) (element (untest (cdddr element))))) (defun variablize-negations (negations) (prog (condition return-list new-condition id value) (setq return-list nil) l1 (cond ((null negations) (return return-list))) (setq condition (pop negations)) (setq new-condition (list (pop condition))) l2 (cond ((null condition) (setq new-condition (nreverse new-condition)) (and (soarmember new-condition return-list) (go l1)) (soarpush new-condition return-list) (go l1))) (soarpush (pop condition) new-condition) (soarpush (pop condition) new-condition) (setq id (pop condition)) (setq value (cdr (soarassq id *learn-ids*))) (cond (value (soarputprop value (1+ (or (get value 'tested) 0)) 'tested)) (t (setq value id))) (soarpush value new-condition) (go l2))) (defun write-trace (arg1 arg2 arg3) (cond ((and *ptrace* (trace-problem-space?)) (soarprintc *decide-count*) (soarprinc3 '":" *cycle-count* arg1) (soarprinc3 arg2 '" " arg3) (soarprinc '" ")))) (defun ops-write1 (z) (prog (port max k x needspace) (cond ((not *in-rhs*) (soarwarn "Write1 cannot be called at the top level." " ") (return nil))) ($reset) (eval-args z) (setq k 1) (setq max ($parametercount)) (cond ((< max 1) (soarwarn "Write1: nothing to print:" z) (return nil))) (setq port (default-write-file)) (setq x ($parameter 1)) (cond ((and (symbolp x) ($ofile x)) (setq port ($ofile x)) (setq k 2))) (setq needspace t) la (and (> k max) (return nil)) (setq x ($parameter k)) (cond ((equal x 'crlf) (setq needspace nil) (terpri port)) ((equal x 'rjust) (setq k (+ 2 k)) (do-rjust ($parameter (1- k)) ($parameter k) port)) ((equal x 'tabto) (setq needspace nil) (setq k (1+ k)) (do-tabto ($parameter k) port)) (t (and needspace (princ " " port)) (setq needspace t) (princ x port))) (setq k (1+ k)) (go la))) (defun ops-write2 (z) (prog (port max k x) (cond ((not *in-rhs*) (soarwarn "Write2 cannot be called at the top level" " ") (return nil))) ($reset) (eval-args z) (setq k 1) (setq max ($parametercount)) (cond ((< max 1) (soarwarn "Write2: nothing to print" " ") (return nil))) (setq port (default-write-file)) (setq x ($parameter 1)) (cond ((and (symbolp x) ($ofile x)) (setq port ($ofile x)) (setq k 2))) la (and (> k max) (return nil)) (setq x ($parameter k)) (cond ((equal x 'crlf) (terpri port)) ((equal x 'rjust) (setq k (+ 2 k)) (do-rjust ($parameter (1- k)) ($parameter k) port)) ((equal x 'tabto) (setq k (1+ k)) (do-tabto ($parameter k) port)) (t (princ x port))) (setq k (1+ k)) (go la))) (defun compose-p-conds (cl) (soar-do ((avlist) (c) (cl1 cl (skip-whole-cond cl1)) (type (car (get-pos-cond cl))) (id-var (get-term (cdddr (get-pos-cond cl))))) ((null cl1) (cons (conv-type-to-sp type) (append id-var (build-sp-cond avlist nil)))) (setq c (get-pos-cond cl1)) (cond ((eq (car c) 'make) (setq c (cdr c)))) (soar-do ((c1 (cddr c) (cdr c1)) (attr '*undefined**) (val '*undefined**) (x)) ((null c1) (cond ((not (eq attr '*undefined**)) (setq x (soarassoc attr avlist)) (cond ((not (eq val '*undefined**)) (cond (x (rplacd x (append val (cdr x)))) (t (soarpush (cons attr val) avlist)))) (t (soarpush (list attr) avlist)))) ((not (eq val '*undefined**)) (soarpush val extravals)))) (setq label (pop c1)) (cond ((eq label 'attribute) (setq attr (cons '^ (get-term c1))) (and (eq (car cl1) '-) (soarpush '- attr))) ((eq label 'value) (setq val (nreverse (get-term c1))))) (pop-term c1)))) (defun conv-to-attr-nums (avlist warnflag) (prog (next a) (setq *filters* nil) (setq next 1) l (and (atom avlist) (return t)) (setq a (car avlist)) (setq avlist (cdr avlist)) (cond ((eq a '^) (setq next (car avlist)) (setq avlist (cdr avlist)) (setq next ($litbind next)) (cond ((or (not (numberp next)) (> next *size-result-array*) (> 1 next)) (and warnflag (soarwarn "Illegal index after ^" next)) (return nil)))) ((variablep a) (soarwarn "(S)PPWM does not take variables:" a) (return nil)) (t (setq *filters* (cons next (cons a *filters*))) (setq next (1+ next)))) (go l))) (defun conv-type-to-sp (type) (soar-do ((cl *sp-classes* (cdr cl))) ((null cl) type) (cond ((eq (cdar cl) type) (return (caar cl)))))) (defun get-ids (infolist oldids) (prog (newids pair) (soarmapc #'(lambda (x) (setq pair (cons (cadddr x) (car x))) (cond ((and (or (not oldids) (soarmember pair oldids)) (not (soarmember pair newids))) (soarpush pair newids)))) infolist) (return newids))) (defun get-pos-cond (cl) (cond ((eq (car cl) '-) (cadr cl)) (t (car cl)))) (defun get-similar-conds (cond cl) (prog (rest result) (setq rest (cons nil cl)) (soar-do ((type (car cond)) (id-var (get-term (cdddr cond))) (negflag) (cl1 rest) (c)) ((or (null cl) (eq (car cl) '-->))) (setq c (pop cl)) (cond ((eq c '-) (setq c (pop cl)) (setq negflag t)) (t (setq negflag nil))) (cond ((eq (car c) 'make) (setq c (cdr c)))) (cond ((and (equal id-var (get-term (cdddr c))) (eq type (car c))) (cond (negflag (soarpush '- result) (rplacd cl1 (cddr cl1)))) (soarpush c result) (rplacd cl1 (cddr cl1))) (t (cond (negflag (setq cl1 (cdr cl1)))) (setq cl1 (cdr cl1))))) (return (cons (nreverse result) (cdr rest))))) (defun get-term (c) (list-head c (skip-term c))) (defun indent nil (soar-do ((i *indent* (- i 1))) ((= i 0)) (princ " " (trace-file)))) (defun list-head (whole tail) (soar-do ((result)) ((null whole) (nreverse result)) (cond ((eq whole tail) (return (nreverse result))) (t (setq result (cons (car whole) result)) (setq whole (cdr whole)))))) (defun p-conds-to-sp (cl) (prog (c pref cl1 result temp negs type) (setq cl1 (copy cl)) l1 (setq c (get-pos-cond cl1)) (cond ((or (null c) (eq c '-->)) (return (nreverse result))) ((eq (car c) 'make) (setq c (cdr c)))) (setq type (car c)) (cond ((soarmemq type *ops5-actions*) (soarpush c result) (setq cl1 (cdr cl1))) ((or (eq type (conv-type-to-sp type)) (not (eq 'identifier (caddr c)))) (cond ((equal (car cl1) '-) (soarpush '- result))) (cond ((and (eq (caddr c) 'object) (eq type 'preference)) (soarpush (cons 'preference (cdddr c)) result)) (t (soarpush c result))) (setq cl1 (skip-whole-cond cl1))) (t (setq temp (get-similar-conds c cl1)) (setq cl1 (cdr temp)) (soarpush (compose-p-conds (car temp)) result))) (go l1))) (defun p-to-sp (rule) (prog (result) (setq result (p-conds-to-sp rule)) (cond ((soarmemq '--> rule) (setq result (append result (cons '--> (p-conds-to-sp (cdr (soarmemq '--> rule)))))))) (return result))) (defun pp-class-ids (ids) (soarmapc #'(lambda (x) (soarmapc #'(lambda (y) (ppline y) (terpri (trace-file))) (p-conds-to-sp (sppwm1 (list (cdr x) '^ 'identifier (car x)))))) ids)) (defun ppelm1 (elm) (prog (ppdat result val att vlist) (setq ppdat (get (car elm) 'ppdat)) (setq result (list (car elm))) (setq vlist (cdr elm)) (soar-do ((curpos 2 (+ 1 curpos))) ((atom vlist)) (setq val (car vlist)) (setq vlist (cdr vlist)) (setq att (cdr (soarassq curpos ppdat))) (cond ((or (not (eq (car elm) 'preference)) (not (null val))) (soarpush '^ result) (soarpush att result) (soarpush val result)))) (return (nreverse result)))) (defun skip-term (c) (car (classify-term c))) (defun skip-whole-cond (cl) (cond ((eq (car cl) '-) (cddr cl)) (t (cdr cl)))) (defun ops-sp (xs) (setq *xs* xs) (soarcatch '!error! (eval (reorder-p-conds (sp-to-p *xs*)))) nil) (defun sp-form-expand (pname x in-actions follows-negation) (prog (nf new-class) (cond ((and (not (atom x)) (eq (car x) 'make)) (setq x (cdr x)))) (setq nf (cond ((atom x) (list x)) ((soarassq (class x) *sp-classes*) (setq new-class (cdr (soarassq (class x) *sp-classes*))) (cond ((not (soarmemq new-class *save-class-list*)) (soarpush new-class *save-class-list*) (soarputprop new-class (get 'state-info 'ppdat) 'ppdat))) (sp-info-expand pname x in-actions)) ((and (cdr x) (not (eq (class x) 'preference)) (not (eq (cadr x) '^)) (or (not in-actions) (not (soarmemq (class x) *ops5-actions*)))) (setq new-class (soarpack2 (class x) '-info)) (soarpush (cons (class x) new-class) *sp-classes*) (soarpush new-class *save-class-list*) (soarputprop new-class (get 'state-info 'ppdat) 'ppdat) (sp-info-expand pname x in-actions)) ((and in-actions (not (soarmemq (car x) *ops5-actions*))) (cond ((and (cdr x) (not (eq (cadr x) '^)) (not (eq (cadr x) '-))) (list (cons 'make (cons (car x) (cons '^ (cons (cond ((eq (car x) 'preference) 'object) (t 'identifier)) (cdr x))))))) (t (list (cons 'make x))))) ((and in-actions (soarmemq (car x) *ops5-actions*)) (list x)) ((and (cdr x) (not (eq (cadr x) '^)) (not (eq (cadr x) '-))) (list (cons (car x) (cons '^ (cons (cond ((eq (car x) 'preference) 'object) (t 'identifier)) (cdr x)))))) (t (list x)))) (cond ((and follows-negation (> (length nf) 1)) (%error "Attempt to negate a compound object" pname)) (t (return nf))))) (defun sp-info-expand (pname form in-actions) (prog (avlist newform end-atom type id clist pand-id temp-form negated no-value) (setq pand-id nil) (setq clist nil) (setq type (cdr (soarassq (car form) *sp-classes*))) (cond ((variablep (cadr form)) (setq id (cadr form)) (setq avlist (cddr form))) ((equal (cadr form) '^) (setq id (soarpack '< 'x (soargensym (car form)) '>)) (setq avlist (cdr form))) ((equal (cadr form) '{) (setq pand-id t) (setq avlist (cddr form)) (setq id (ncons '{)) (soarwhile (and avlist (not (equal (car avlist) '}))) (soarpush (car avlist) id) (pop avlist)) (cond ((null avlist) (%error "Didn't find terminating }" form))) (setq id (dreverse (cons '} id))) (setq avlist (cdr avlist))) (t (setq id (cadr form)) (setq avlist (cddr form)))) loop (cond ((not avlist) (return (reverse clist)))) (setq negated nil) (cond ((equal (car avlist) '-) (pop avlist) (setq negated t))) (cond ((not (equal (car avlist) '^)) (%error "Didn't find a ^ when expected" avlist))) (pop avlist) (setq end-atom (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil))) (cond (pand-id (setq newform (append (list type '^ 'identifier) (append id (list '^ 'attribute (pop avlist)))))) (t (setq newform (list type '^ 'identifier id '^ 'attribute (pop avlist))))) (cond (end-atom (soarwhile (and avlist (not (eq (car avlist) end-atom))) (setq newform (append newform (list (pop avlist))))) (cond ((null avlist) (%error "Didn't find terminator" end-atom))) (setq newform (append newform (list (pop avlist)))))) (setq no-value t) (cond ((and avlist (not (eq (car avlist) '^)) (not (eq (car avlist) '-)) (or (not (soarlistp (car avlist))) (not (eq (caar avlist) '^)))) (setq newform (append newform (list '^ 'value))) (setq no-value nil))) (setq temp-form newform) (soarwhile (and avlist (not (eq (car avlist) '^)) (not (eq (car avlist) '-)) (or (not (soarlistp (car avlist))) (not (eq (caar avlist) '^)))) (setq newform temp-form) (cond ((predicatep (car avlist)) (setq newform (append newform (list (pop avlist)))))) (setq end-atom (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil))) (setq newform (append newform (list (pop avlist)))) (cond (end-atom (soarwhile (and avlist (not (eq (car avlist) end-atom))) (setq newform (append newform (list (pop avlist))))) (cond ((null avlist) (%error "Didn't find terminator" end-atom))) (setq newform (append newform (list (pop avlist)))))) (cond ((and avlist (soarlistp (car avlist))) (setq newform (append newform (pop avlist))))) (cond (in-actions (soarpush 'make newform))) (cond (negated (soarpush '- clist))) (soarpush newform clist)) (cond (no-value (cond ((and avlist (soarlistp (car avlist))) (setq newform (append newform (pop avlist))))) (cond (in-actions (soarpush 'make newform))) (cond (negated (soarpush '- clist))) (soarpush newform clist))) (go loop))) (defun sp-to-p (xs) (prog (in-actions follows-negation forms pname) (setq in-actions nil) (setq follows-negation nil) (setq pname (car xs)) (return (cons 'p (soarmapconc #'(lambda (x) (cond ((equal x '-->) (setq in-actions t))) (setq forms (sp-form-expand pname x in-actions follows-negation)) (setq follows-negation (eq x '-)) forms) xs))))) (defun ops-spm (z) (setq *indent* 0) (soarmapc #'(lambda (x) (pprule x 'sp)) z) nil) (defun spm-to-make (form) (soarmapc #'eval (sp-info-expand nil form t)) nil) (defun ops-spo (object) (setq *indent* 0) (cond ((or (null object) (numberp (car object)))) ((not (numberp (soarlast object))) (terpri (trace-file)) (spo1 (car object) *spo-default-depth* nil) (eval (cons 'spo (cdr object)))) (t (terpri (trace-file)) (spo1 (car object) (soarlast object) nil) (eval (cons 'spo (cdr object))))) (setq *print-spo-list* nil)) (defun spo1 (object depth prefflag) (prog (out class out2 out1) (cond ((soarmemq object *print-spo-list*) (return)) (t (soarpush object *print-spo-list*))) (setq out (p-conds-to-sp (sppwm1 (append '(^ identifier) (list object))))) (setq out1 nil) (soarmapc #'(lambda (x) (cond ((eq prefflag (eq (car x) 'preference)) (ppline x) (soarpush x out1) (terpri (trace-file))))) out) (cond ((<= depth 1) (return))) (setq out out1) (setq *indent* (+ *indent* 3)) (soar-do ((out2 out (cdr out2))) ((null out2)) (soar-do ((out1 (cdar out2) (cdr out1))) ((null out1)) (cond ((get (cadr out1) 'in-id-field) (spo1 (cadr out1) (- depth 1) prefflag))))) (setq *indent* (- *indent* 3)))) (defun ops-sppwm (avlist) (prog (noclassflag condlist cond1 ids avinfos) (soarterpri) (setq *indent* 0) (cond ((null avlist) (go l2)) ((not (soarassoc (car avlist) *sp-classes*)) (setq avlist (cons 'state avlist)) (setq noclassflag t))) (cond ((null (cdr avlist)) (setq avinfos (list (list (cdr (soarassoc (car avlist) *sp-classes*)))))) ((null (cddr avlist)) (setq avinfos (list (list (cdr (soarassoc (car avlist) *sp-classes*)) '^ 'identifier (cadr avlist))))) (t (soarcatch '!error! (setq avinfos (sp-form-expand nil avlist nil nil))))) (cond ((variablep (cadddr (car avinfos))) (soarmapc #'(lambda (x) (rplacd x (cdr (cdddr x)))) avinfos))) (cond (noclassflag (setq avinfos (soarmapcar #'cdr avinfos)) (setq avlist (cdr avlist)))) (setq ids (get-ids (sppwm1 (car avinfos)) nil)) l1 (setq avinfos (cdr avinfos)) (cond ((null avinfos) (go l2))) (setq ids (get-ids (sppwm1 (car avinfos)) ids)) (cond ((null ids) (go l3))) (go l1) l2 (cond (avlist (setq ids (append ids (get-ids (sppwm1 avlist) nil))))) (pp-class-ids ids) l3 )) (defun sppwm1 (avlist) (cond ((not (conv-to-attr-nums avlist nil)) nil) (t (mapwm #'sppwm2) (prog2 nil *wm* (setq *wm* nil))))) (defun sppwm2 (elm-tag) (cond ((filter (car elm-tag)) (setq *wm* (cons (ppelm1 (car elm-tag)) *wm*))))) (defun ops-spr (arg) (cond ((get (car arg) 'in-id-field) (eval (cons 'spo arg))) ((soarmemq (car arg) *pnames*) (eval (cons 'spm arg))) ((numberp (car arg)) (eval (cons 'swm arg))) ((null (car arg)) (pgs)) (t (eval (cons 'sppwm arg))))) (defun ops-swm (a) (pp-class-ids (soarmapcar #'(lambda (x) (cons (cadr x) (car x))) (get-wm a)))) (defun $varbind (x) (prog (r) (and (not *in-rhs*) (return x)) (setq r (soarassq x *variable-memory*)) (cond (r (return (cdr r))) ((variablep x) (setq r (soargensym (soarnthchar x 2))) (make-var-bind x r) (return r)) (t (return x))))) (defun &bus (outs) (prog (dp) (setq *alpha-flag-part* *flag-part*) (setq *alpha-data-part* *data-part*) (setq dp (car *data-part*)) (setq *c1* (car dp)) (setq dp (cdr dp)) (setq *c2* (car dp)) (setq dp (cdr dp)) (setq *c3* (car dp)) (setq dp (cdr dp)) (setq *c4* (car dp)) (setq dp (cdr dp)) (setq *c5* (car dp)) (setq dp (cdr dp)) (setq *c6* (car dp)) (setq dp (cdr dp)) (setq *c7* (car dp)) (setq dp (cdr dp)) (setq *c8* (car dp)) (setq dp (cdr dp)) (setq *c9* (car dp)) (setq dp (cdr dp)) (setq *c10* (car dp)) (setq dp (cdr dp)) (setq *c11* (car dp)) (setq dp (cdr dp)) (setq *c12* (car dp)) (setq dp (cdr dp)) (setq *c13* (car dp)) (setq dp (cdr dp)) (setq *c14* (car dp)) (setq dp (cdr dp)) (setq *c15* (car dp)) (setq dp (cdr dp)) (setq *c16* (car dp)) (eval-nodelist outs))) (defun &priv (outs name) (prog nil (eval-nodelist outs))) (defun accum-stats nil (setq *prod-count* (+ *prod-count* 1)) (setq *total-token* (+ *total-token* *current-token*)) (cond ((> *current-token* *max-token*) (setq *max-token* *current-token*))) (setq *total-wm* (+ *total-wm* *current-wm*)) (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) (defun add-to-wm (wme) (prog (class part timetag port match-time) (setq port (trace-file)) (setq wme (eliminate-trailing-nil wme)) (setq class (class wme)) (setq part (get class 'wmpart*)) (cond ((soarassoc wme part) (and *chunk-all-paths* (mark-in-id wme)) (return nil)) ((mark-in-id wme) (return nil)) ((soarmember wme *brkrun*) (setq *break-flag* t))) (trace-condition-action wme 'action) (setq *critical* t) (setq *action-count* (1+ *action-count*)) (setq *current-wm* (1+ *current-wm*)) (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))) (or (soarmemq class *wmpart-list*) (soarpush class *wmpart-list*)) (setq timetag *action-count*) (soarputprop class (cons (cons wme timetag) part) 'wmpart*) (match 'new wme) (setq *critical* nil) (cond ((or (not *in-rhs*) (not (trace-problem-space?)))) ((and (not *wtrace*) *ptrace* *ttrace*) (time-tag-print (list wme) port)) (*wtrace* (soarprintc "=>WM: ") (ppelm wme port))))) (defun best-of (set) (prog (cs entry best-list) (setq cs set) (setq best-list nil) l1 (setq entry (car cs)) (setq cs (cdr cs)) (cond ((null entry) (return best-list)) ((or (eq *phase* (get (car entry) 'type)) (and (eq *phase* 'elaborate) (eq (get (car entry) 'type) 'elaborate-once))) (soarpush entry best-list) (and (eq *phase* 'elaborate) (remove-cs entry)))) (go l1))) (defun ops-bind (z) (prog (val) (cond ((not *in-rhs*) (soarwarn "Cannot be called at top level" 'bind) (return nil)) ((< (length z) 1) (soarwarn "Bind: Wrong number of arguments to" z) (return nil)) ((not (symbolp (car z))) (soarwarn "Bind: illegal argument" (car z)) (return nil)) ((equalp (length z) 1) (setq val (soargensym 's))) (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1)))) (make-var-bind (car z) val))) (defun check-action (x) (prog (a) (cond ((atom x) (soarwarn "Atomic Action" x) (return nil))) (setq a (setq *action-type* (car x))) (cond ((eq a 'bind) (check-bind x)) ((eq a 'cbind) (check-cbind x)) ((eq a 'call2) (return nil)) ((eq a 'tabstop) (check-bind x)) ((eq a 'decide) (check-decide)) ((eq a 'make) (check-make x)) ((eq a 'modify) (check-modify x)) ((eq a 'remove-ops) (check-remove-ops x)) ((eq a 'write) (check-write x)) ((eq a 'write1) (check-write x)) ((eq a 'write2) (check-write x)) ((eq a 'call1) (check-call1 x)) ((eq a 'halt) (check-halt x)) ((eq a 'openfile) (check-openfile x)) ((eq a 'closefile) (check-closefile x)) ((eq a 'default) (check-default x)) ((eq a 'build) (check-build x)) (t (soarwarn "Illegal Action" x))))) (defun check-make (z) (or (soarmemq *p-type* '(elaborate-once elaborate)) (soarwarn "Illegal make in production type" *p-type*)) (and (null (cdr z)) (soarwarn "Missing arguments in Make" " ")) (check-change& (cdr z))) (defun check-modify (z) (soarwarn "Illegal modify in Soar production" *p-type*) (and (null (cdr z)) (soarwarn "Missing arguments in Modify" " ")) (check-rhs-ce-var (cadr z)) (and (null (cddr z)) (soarwarn "No changes to make in Modify" " ")) (check-change& (cddr z))) (defun check-rhs-value (x) (cond ((soarlistp x) (check-rhs-function x)))) (defun cmp-ce nil (prog (z) (new-subnum 0) (setq *cur-vars* nil) (setq z (lex)) (and (atom z) (%error "Atomic conditions are not allowed" z)) (setq *preference-found* (eq (car z) 'preference)) (prepare-sublex z) la (and (end-of-ce) (return nil)) (incr-subnum) (cmp-element) (setq *context-field-found* nil) (go la))) (defun cmp-tab nil (prog (r) (sublex) (setq r (sublex)) (setq *context-field-found* (and *preference-found* (soarmemq r '(goal problem-space state operator)))) (setq r ($litbind r)) (new-subnum r))) (defun cmp-var (test) (prog (old name) (setq name (sublex)) (setq old (soarassq name *cur-vars*)) (cond ((and old (eq (cadr old) 'eq)) (cmp-old-eq-var test old)) ((and old (eq test 'eq)) (cmp-new-eq-var name old)) ((and (eq test 'eq) *context-field-found*) (cmp-new-var name 'eqnil)) (t (cmp-new-var name test))))) (defun cmp-p (name type matrix) (prog (m bakptrs root) (cond ((soarlistp name) (%error "Illegal production name" name)) ((equal (get name 'production) matrix) (return nil))) (cond ((not (soarmemq type '(elaborate elaborate-once decide))) (%error "Illegal production type" type))) (and *print-pname* (princ name (trace-file))) (prepare-lex matrix) (cond ((excise-p name) (princ (list 'excised name) (trace-file)))) (setq bakptrs nil) (setq *last-node* *first-node*) (and (> *current-wm* 0) (make-new-root name)) (setq root (setq *new-root* *last-node*)) (setq *pcount* (1+ *pcount*)) (setq *feature-count* 0) (setq *ce-count* 0) (setq *vars* nil) (setq *ce-vars* nil) (setq *rhs-bound-vars* nil) (setq *rhs-bound-ce-vars* nil) (setq *last-branch* nil) (setq m (rest-of-p)) l1 (and (end-of-p) (%error "No '-->' in production" m)) (setq *last-node* root) (cmp-prin) (setq bakptrs (cons *last-branch* bakptrs)) (or (eq '--> (peek-lex)) (go l1)) (lex) (cond ((not (soarmemq name *pnames*)) (setq *pnames* (cons name *pnames*)))) (check-rhs (rest-of-p)) (link-new-node (list '&p *feature-count* name (encode-dope) (encode-ce-dope) (cons 'progn (rest-of-p)))) (soarputprop name type 'type) (soarputprop name (cdr (nreverse bakptrs)) 'backpointers) (soarputprop name matrix 'production) (soarputprop name (compute-negation-index matrix) 'negation-index) (soarputprop name *last-node* 'topnode) (cond ((> *current-wm* 0) (mapwm #'match-update))) (return nil))) (defun cmp-prin nil (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta)) ((eq (peek-lex) '-) (cmp-negce) (cmp-not)) (t (cmp-posce) (cmp-and)))) (defun compile-production (name type matrix) (setq *p-type* type) (setq *matrix* matrix) (setq *p-name* name) (soarcatch '!error! (cmp-p *p-name* *p-type* *matrix*)) (setq *p-name* nil)) (defun conflict-resolution nil (prog (best len) (setq len (length *conflict-set*)) (cond ((> len *max-cs*) (setq *max-cs* len))) (setq *total-cs* (+ *total-cs* len)) (cond (*conflict-set* (setq best (best-of *conflict-set*)) (cond ((neq *phase* 'decide) (soarmapc #'remove-cs best))) (return best)) (t (return nil))))) (defun conflict-set nil (prog (cnts cs p z phase-type) (setq cnts nil) (setq cs *conflict-set*) (setq phase-type 'decide) l1 (and (atom cs) (go l2)) (setq p (caar cs)) (and (neq (get p 'type) 'decide) (setq phase-type 'elaborate)) (setq cs (cdr cs)) (setq z (soarassq p cnts)) (cond ((null z) (setq cnts (cons (cons p 1) cnts))) (t (rplacd z (1+ (cdr z))))) (go l1) l2 (cond ((atom cnts) (terpri (trace-file)) (return (list 'phase phase-type)))) (cond ((and (eq phase-type 'elaborate) (eq (get (caar cnts) 'type) 'decide)) (setq cnts (cdr cnts)) (go l2))) (terpri (trace-file)) (soarprinc3 (caar cnts) " " (get (caar cnts) 'type)) (cond ((> (cdar cnts) 1) (soarprinc3 " (" (cdar cnts) " OCCURRENCES)"))) (setq cnts (cdr cnts)) (go l2))) (defun ops-crlf (z) (cond (z (soarwarn "CRLF: Does not take arguments" z)) (t ($value 'crlf)))) (defun do-continue (wmi) (cond (*critical* (soarprintc "WARNING: Network may be inconsistent"))) (process-changes wmi nil) (main)) (defun eval-rhs (pname data) (prog (node port) (cond ((and (trace-problem-space?) (or *ptrace* (soarmemq pname *tracep-list*))) (setq port (trace-file)) (soarprintc (1+ *decide-count*)) (soarprinc3 ":" *cycle-count* " ") (soarprinc pname) (and *ptrace* *ttrace* (time-tag-print data port)))) (setq *data-matched* data) (setq *p-name* pname) (setq *last* nil) (setq node (get pname 'topnode)) (init-var-mem (var-part node)) (init-ce-var-mem (ce-var-part node)) (setq *in-rhs* t) (setq *current-goal* (find-max-goal-depth *data-matched*)) (soarmapc #'condition-trace *data-matched*) (cond ((null *never-learn*) (setq *data-matched* (append (add-negations *current-goal* (reverse *data-matched*)) *data-matched*)))) (eval (rhs-part node)) (setq *in-rhs* nil))) (defun excise-p (name) (prog nil (cond ((and (symbolp name) (get name 'topnode)) (princ "#" (trace-file)) (setq *pcount* (1- *pcount*)) (remove-from-conflict-set name) (kill-node (get name 'topnode)) (remprop name 'production) (remprop name 'backpointers) (remprop name 'topnode) (remprop name 'type) (remprop name 'negation-index) (setq *chunks* (dremove name *chunks*)) (setq *pnames* (dremove name *pnames*)) (and (get name 'gensymed) (setq *free-pname-list* (soarsort (cons name *free-pname-list*)))) (return t)) (t (return nil))))) (defun finish-literalize nil (cond ((not (null *class-list*)) (soarmapc #'note-user-assigns *class-list*) (soarmapc #'assign-scalars *class-list*) (soarmapc #'assign-vectors *class-list*) (soarmapc #'put-ppdat *class-list*) (soarmapc #'erase-literal-info *class-list*) (setq *value-index* (1- (literal-binding-of 'value))) (setq *attribute-index* (1- (literal-binding-of 'attribute))) (setq *id-index* (1- (literal-binding-of 'identifier))) (setq *goal-index* (1- (literal-binding-of 'goal))) (setq *problem-space-index* (1- (literal-binding-of 'problem-space))) (setq *state-index* (1- (literal-binding-of 'state))) (setq *operator-index* (1- (literal-binding-of 'operator))) (setq *slot-index* (1- (literal-binding-of 'role))) (setq *big-info-index* (max *id-index* *attribute-index* *value-index*)) (setq *big-index* (max *id-index* *goal-index* *problem-space-index* *state-index* *operator-index* *value-index* *slot-index*)) (setq *save-class-list* *class-list*) (setq *class-list* nil) (setq *buckets* nil)))) (defun i-g-v nil (prog (x) (setq *save-class-list* nil) (setq *class-list* nil) (soarsyntax) (soarputprop 'identifier 2 'ops-bind) (soarputprop 'object 2 'ops-bind) (soarputprop 'attribute 3 'ops-bind) (soarputprop 'value 4 'ops-bind) (setq *sp-classes* '((state . state-info) (object . info) (problem-space . space-info) (space . space-info) (operator . op-info) (desired . desired-info) (gc . goal-context-info) (goal . goal-context-info) (context . goal-context-info) (goal-context . goal-context-info) (evaluation . eval-info))) (setq *ops5-actions* '(openfile closefile default write write1 write2 call1 halt decide bind call2 cbind obind build tabto tabstop)) (setq *impasse-subset-not-equal* nil) (setq *brkpts* nil) (setq *brkrun* nil) (setq *brknames* nil) (setq *default-multi* 5) (setq *warning* t) (setq *order-trace* nil) (setq *print-pname* nil) (setq *buckets* 16) (setq *accept-file* nil) (setq *write-file* nil) (setq *trace-file* nil) (setq *strategy* 'lex) (setq *user-ids* nil) (setq *in-rhs* nil) (setq *decide-trace* nil) (setq *pick-first-condition* t) (setq *max-recurse* 2) (setq *multi-attribute* nil) (multi-attributes '((problem-space operator) (goal item) (state evaluation 2))) (setq *instance-attributes* nil) (trace-attributes '((goal role) (goal impasse) (goal desired) (goal superoperator) (operator object) (operator instance))) (setq *watch-free-problem-spaces* nil) (setq *chunk-free-problem-spaces* nil) (setq *tracep-list* nil) (setq *cav* nil) (setq *cavi* nil) (setq *tracep* t) (setq *max-chunk-conditions* 200) (setq *subgoal-results* nil) (setq *chunk-all-paths* t) (setq *smaller-chunks* nil) (setq *chunks* nil) (setq *chunk-classes* '(problem-space state operator)) (setq *always-learn* t) (setq *new-chunks* nil) (setq *wme-list-stack* nil) (setq *learn-ids* nil) (setq *learning* nil) (setq *ltrace* nil) (setq *never-learn* t) (setq *print-learn* 0) (setq *split-actions* t) (setq *select-equal* 'first) (setq *default-user-select* t) (setq *pnames* nil) (setq *free-pname-list* nil) (setq *used-gensym-list* nil) (setq *free-gensym-list* (list (list 'free-list))) (setq *used-var-list* nil) (setq *used-char-list* nil) (init-gensym) (soarmapc #'(lambda (x) (soarputprop x 't 'predicate)) '(< <= <=> <> = > >=)) (setq *recording* nil) (setq *refracts* nil) (setq *real-cnt* (setq *virtual-cnt* 0)) (setq *limit-token* 1000000) (setq *limit-cs* 1000000) (setq *critical* nil) (setq *wmpart-list* nil) (setq *global-pair* (list 'nil)) (setq *subgoal-tabs* t) (setq *size-result-array* 15) (setq *result-array* (makevector 16)) (setq *record-array* (makevector 16)) (setq x 0) loop (putvector *result-array* x nil) (putvector *record-array* x nil) (setq x (1+ x)) (and (not (> x *size-result-array*)) (go loop)) (make-bottom-node) (setq *pcount* 0) (setq *already-fired* nil) (setq *current-goal* nil) (soarmachinetype) (setq *spo-default-depth* 1) (setq *print-spo-list* nil) (setq *indent* 0) (watch 0) (swatch 0) (setq *max-elaborations* 100) (setq *remaining-cycles* 1000000) (setq *remaining-decide* 1000000) (setq *version-number* "4") (setq *minor-version* "0") (setq *release-number* "1") (setq *public-version* t) (setq *date-created* "November 14, 1985") (soar-greeting) (init-literalizes) (init-soar))) (defun soar-greeting nil (soarprintc "Soar ") (cond (*public-version* (soarprinc "(Version ") (soarprinc *version-number*) (soarprinc ", Release ") (soarprinc *release-number*) (soarprinc ")")) (t (soarprinc *version-number*) (soarprinc ".") (soarprinc *minor-version*))) (soarprintc "Created ") (soarprint *date-created*) (cond (*public-version* (soarprint "Bugs and questions to soar@h.cs.cmu.edu"))) (soarprint "Copyright (c) 1985 Xerox Corporation. All Rights Reserved.") (terpri) (soarprint "Use of this software is permitted for non-commercial") (soarprint "research purposes, and it may be copied only for that use.") (soarprint "This software is made available AS IS, and Xerox") (soarprint "Corporation, Stanford University and Carnegie-Mellon") (soarprint "University make no warranty about the software or its") (soarprint "performance.") ) (defun insertcs (name data rating) (prog (instan) (and (refracted name data) (return nil)) (setq instan (cons name data)) (and (atom *conflict-set*) (setq *conflict-set* nil)) (return (setq *conflict-set* (cons instan *conflict-set*))))) (defun instantiation (conflict-elem) (cdr (pname-instantiation conflict-elem))) (defun main nil (prog (phase-set r) (setq *halt-flag* nil) (setq *break-flag* nil) (setq *elaborations-count* 0) (setq phase-set nil) dil (cond (*halt-flag* (setq r "End -- Explicit Halt") (go finis)) ((or (zerop *remaining-decide*) (zerop *remaining-cycles*)) (setq *break-flag* t))) (cond ((or *break-flag* ; (readp t) ) (setq r '***break***) (go finis))) (setq *first-remove* (setq *first-action* t)) (setq phase-set (conflict-resolution)) (cond ((eq *phase* 'decide) (setq *remaining-cycles* (1- *remaining-cycles*)) (setq *remaining-decide* (1- *remaining-decide*)) (setq *cycle-count* (1+ *cycle-count*)) (setq *decide-count* (1+ *decide-count*)) (setq *elaborations-count* 0) (setq *in-rhs* t) (process-decide phase-set) (setq *in-rhs* nil) (setq *phase* 'elaborate)) ((not phase-set) (setq *phase* 'decide)) (t (setq *cycle-count* (1+ *cycle-count*)) (cond ((and *wtrace* (trace-problem-space?)) (soarprintc "--Elaboration Phase--"))) (setq *already-fired* nil) (soarmapc #'process-instance phase-set) (setq *remaining-cycles* (1- *remaining-cycles*)) (setq *elaborations-count* (1+ *elaborations-count*)) (cond ((eq *max-elaborations* *elaborations-count*) (soarwarn "Exceeded *max-elaborations*. Proceeding to decision procedure." *max-elaborations*) (setq *phase* 'decide))))) (go dil) finis (setq *p-name* nil) (terpri (trace-file)) (return r))) (defun ops-p (z) (finish-literalize) (princ '* (trace-file)) (cond ((soarlistp (cadr z)) (compile-production (car z) 'elaborate (cdr z))) (t (compile-production (car z) (cadr z) (cddr z))))) (defun ops-pbreak (z) (cond ((atom z) (terpri (trace-file)) (soarprinc2 "Production breaks:" *brkpts*) (terpri (trace-file)) (soarprinc2 "Name/identifier breaks:" *brknames*) (terpri (trace-file)) nil) (t (soarmapc #'pbreak2 z) z))) (defun pbreak2 (rule) (prog (type blist) (cond ((or (not (symbolp rule)) (soarlistp rule)) (soarwarn "Illegal argument:" rule)) ((or (soarmemq rule *brkpts*) (soarmemq rule *brknames*)) nil) ((get rule 'topnode) (soarpush rule *brkpts*) rule) (t (soarpush rule *brknames*) rule)))) (defun pname-instantiation (conflict-elem) conflict-elem) (defun ops-pm (z) (soarmapc #'(lambda (x) (pprule x nil)) z) nil) (defun ppattval nil (prog (att val) (setq att (cadr *ppline*)) (setq *ppline* (cddr *ppline*)) (cond ((or (null *ppline*) (eq (car *ppline*) '^)) (setq val nil)) (t (setq val (getval)))) (cond ((> (+ (nwritn t) (flatc att) (flatc val)) 76) (soarprintc " ") (indent))) (soarprinc2 '^ att) (soarmapc #'(lambda (z) (soarprinc2 " " z)) val))) (defun ppline (line) (prog nil (indent) (cond ((atom line) (princ line (trace-file))) (t (princ "(" (trace-file)) (setq *ppline* line) (ppline2) (princ ")" (trace-file)))) (return nil))) (defun pponlyval nil (prog (val needspace) (setq val (getval)) (setq needspace nil) (cond ((> (+ (nwritn t) (flatc val)) 76) (setq needspace nil) (soarprintc " ") (indent))) top (and (atom val) (return nil)) (and needspace (princ " " (trace-file))) (setq needspace t) (princ (car val) (trace-file)) (setq val (cdr val)) (go top))) (defun pprule (name flag) (prog (matrix next lab port) (and (not (symbolp name)) (return nil)) (setq matrix (get name 'production)) (and (null matrix) (return nil)) (setq port (trace-file)) (soarprintc "(") (cond ((eq flag 'sp) (setq matrix (p-to-sp matrix)) (princ 'sp port)) (t (princ 'p port))) (soarprinc2 " " name) (and (eq 'decide (get name 'type)) (soarprinc2 " " 'decide)) top (and (atom matrix) (go fin)) (setq next (car matrix)) (setq matrix (cdr matrix)) (setq lab nil) (terpri port) (cond ((eq next '-) (princ " - " port) (setq next (car matrix)) (setq matrix (cdr matrix))) ((eq next '-->) (princ " " port)) ((and (eq next '{) (atom (car matrix))) (princ " {" port) (setq lab (car matrix)) (setq next (cadr matrix)) (setq matrix (cdddr matrix))) ((eq next '{) (princ " {" port) (setq lab (cadr matrix)) (setq next (car matrix)) (setq matrix (cdddr matrix))) (t (princ " " port))) (ppline next) (cond (lab (soarprinc3 " " lab "}"))) (go top) fin (soarprint ")"))) (defun ops-ppwm (avlist) (conv-to-attr-nums avlist t) (mapwm #'ppwm2) nil) (defun print-stats nil (setq *break-flag* nil) (print-times "Run Statistics")) (defun print-times (mess) (prog (cc ac pc dc time d-time) (setq time (time-conversion *elapsed-time*)) (setq dc (+ (float *decide-count*) 1.0e-20)) (setq cc (+ (float *cycle-count*) 1.0e-20)) (setq pc (+ (float *prod-count*) 1.0e-20)) (setq ac (+ (float *action-count*) 1.0e-20)) (soarprintc mess) (pm-size) (cond ((eq *decide-count* 0) (terpri (trace-file)) (return))) (printline (list time " Seconds Elapsed")) (cond ((eq time 0) (setq time 1.0e-8))) (printline (list *decide-count* " Decision Cycles " (list (quotient (float *decide-count*) time) " Per Sec."))) (printline (list *cycle-count* " Prod Cycles " (list (quotient (float *cycle-count*) time) " Per Sec.") " " (list (- (quotient (float *cycle-count*) dc) 1) " E cycles/ D cycle"))) (printline (list *prod-count* " Prod. Firings " (list (quotient (float *prod-count*) time) " Per Sec.") " " (and (< 0.01 (- cc *decide-count*)) (list (quotient (float (- *prod-count* *decide-count*)) (- cc *decide-count*)) " Elab. prod. in parallel")))) (printline (list *action-count* " RHS Actions " (list (quotient (float *action-count*) time) " Per Sec."))) (printline (list (round (quotient (float *total-cs*) cc)) " Mean conflict set size " (list *max-cs* " Maximum"))) (printline (list (round (quotient (float *total-wm*) pc)) " Mean working memory size " (list *max-wm* " Maximum " *current-wm* " Current "))) (printline (list (round (quotient (float *total-token*) pc)) " Mean token memory size " (list *max-token* " Maximum " *current-token* " Current "))))) (defun promote-var (dope) (prog (vname vpred vpos new) (setq vname (car dope)) (setq vpred (cadr dope)) (setq vpos (caddr dope)) (cond ((eq vpred 'eqnil) (setq vpred 'eq)) ((not (eq vpred 'eq)) (%error "Illegal predicate for first occurrence" (list vname vpred)))) (setq new (list vname 0 vpos)) (setq *vars* (cons new *vars*)))) (defun remove-cs (entry) (setq *conflict-set* (dremove entry *conflict-set*))) (defun remove-from-conflict-set (name) (prog (cs entry) l1 (setq cs *conflict-set*) l2 (cond ((atom cs) (return nil))) (setq entry (car cs)) (setq cs (cdr cs)) (cond ((eq name (car entry)) (setq *conflict-set* (dremove entry *conflict-set*)) (go l1)) (t (go l2))))) (defun remove-from-wm (wme) (prog (class z part timetag port match-time) (setq port (trace-file)) (setq wme (eliminate-trailing-nil wme)) (setq class (wm-hash wme)) (setq part (get class 'wmpart*)) (setq z (cond ((eq class 'goal-context-info) (soarassoc wme part)) (t (soarassq wme part)))) (or z (return nil)) (setq wme (car z)) (setq timetag (cdr z)) (cond ((and *in-rhs* *first-remove*) (and *ptrace* *ttrace* (trace-problem-space?) (not *wtrace*) (princ " <--" port)) (setq *first-action* t) (setq *first-remove* nil))) (cond ((or (not *in-rhs*) (not (trace-problem-space?)))) ((and (not *wtrace*) *ptrace* *ttrace*) (time-tag-print (list wme) port)) (*wtrace* (soarprintc "<=WM: ") (ppelm wme port))) (setq *action-count* (1+ *action-count*)) (setq *critical* t) (setq *current-wm* (1- *current-wm*)) (match nil wme) (soarputprop class (dremove z part) 'wmpart*) (setq *critical* nil))) (defun removecs (name data) (prog (cr-data inst cs) (setq cr-data (cons name data)) (setq cs *conflict-set*) l (cond ((null cs) (record-refract name data) (return nil))) (setq inst (car cs)) (setq cs (cdr cs)) (and (not (top-levels-eq inst cr-data)) (go l)) (setq *conflict-set* (dremove inst *conflict-set*)))) (defun ops-rjust (z) (prog (val) (cond ((not (== (length z) 1)) (soarwarn "RJUST: Wrong number of arguments" z) (return nil))) (setq val ($varbind (car z))) (cond ((or (not (numberp val)) (< val 1) (> val 127)) (soarwarn "RJUST: Illegal value for field width" val) (return nil))) ($value 'rjust) ($value val))) (defun ops-run (z) (prog (result) (cond ((eq *pcount* 0) (terpri (trace-file)) (soarprint "Please load in some productions first.") (return nil))) (init-wm) (setq *brkrun* nil) (setq *begin-time* (alwaystime)) (setq *remaining-decide* 1000000) (setq *remaining-cycles* 1000000) (cond ((atom z)) ((and (atom (cdr z)) (numberp (car z)) (> (car z) -1)) (setq *remaining-cycles* (car z))) ((and (numberp (car z)) (eq (cadr z) 'd)) (setq *remaining-decide* (car z))) ((soarlistp (car z)) (setq *brkrun* (conv-input-wme (car z))) (and (null *brkrun*) (return "What?"))) (t (setq *brkrun* (car z)))) (setq result (do-continue nil)) (setq *elapsed-time* (+ *elapsed-time* (- (alwaystime) *begin-time*))) (return result))) (defun ops-tabto (z) (prog (val) (cond ((not (== (length z) 1)) (soarwarn "TABTO: Wrong number of arguments" z) (return nil))) (setq val ($varbind (car z))) (cond ((or (not (numberp val)) (< val 1) (> val 127)) (soarwarn "TABTO: Illegal column number" val) (return nil))) ($value 'tabto) ($value val))) (defun ops-watch (z) (cond ((equal z '(-1)) (setq *wtrace* nil) (setq *ptrace* nil) (setq *otrace* nil) -1) ((equal z '(0)) (setq *wtrace* nil) (setq *ptrace* nil) (setq *otrace* t) 0) ((equal z '(0.5)) (setq *wtrace* nil) (setq *ptrace* t) (setq *ttrace* nil) (setq *otrace* t) 0.5) ((equal z '(1)) (setq *wtrace* nil) (setq *ptrace* t) (setq *ttrace* t) (setq *otrace* t) 1) ((equal z '(1.5)) (setq *wtrace* t) (setq *ttrace* nil) (setq *ptrace* t) (setq *otrace* t) 1.5) ((equal z '(2)) (setq *wtrace* t) (setq *ttrace* t) (setq *ptrace* t) (setq *otrace* t) 2) ((equal z '(3)) (setq *otrace* t) (setq *wtrace* t) (setq *ptrace* t) '(2 -- conflict set trace not supported)) ((and (atom z) (null *otrace*)) -1) ((and (atom z) (null *ptrace*)) 0) ((and (atom z) (null *wtrace*)) 1) ((atom z) 2) (t 'what?))) (defun wm-hash (x) (car x)) (defun ops-write (z) (prog (port max k x needspace) (cond ((not *in-rhs*) (soarwarn "Write cannot be called at the top level" " ") (return nil))) ($reset) (eval-args z) (setq k 1) (setq max ($parametercount)) (cond ((< max 1) (soarwarn "Write: nothing to print:" z) (return nil))) (setq port (default-write-file)) (setq x ($parameter 1)) (cond ((and (symbolp x) ($ofile x)) (setq port ($ofile x)) (setq k 2))) (setq needspace t) la (and (> k max) (return nil)) (setq x ($parameter k)) (cond ((equal x 'crlf) (setq needspace nil) (terpri port)) ((equal x 'rjust) (setq k (+ 2 k)) (do-rjust ($parameter (1- k)) ($parameter k) port)) ((equal x 'tabto) (setq needspace nil) (setq k (1+ k)) (do-tabto ($parameter k) port)) (t (and needspace (princ " " port)) (setq needspace t) (princ x port))) (setq k (1+ k)) (go la))) (defun add-negations (current-goal data-matched) (prog (negation-list return-list negation var-list condition new-condition element) (and (null *p-name*) (return nil)) (and (null (get *p-name* 'negation-index)) (return nil)) (setq return-list nil) (setq negation-list (car (get *p-name* 'negation-index))) (setq var-list (cadr (get *p-name* 'negation-index))) l1 (cond ((null negation-list) (return return-list))) (setq condition (pop negation-list)) (setq new-condition (list (pop condition))) l2 (cond ((null condition) (setq new-condition (nreverse new-condition)) (soarpush '- return-list) (soarpush new-condition return-list) (go l1))) (soarpush (pop condition) new-condition) (soarpush (pop condition) new-condition) (cond ((variablep (car condition)) (setq element (cdr (soarassq (pop condition) var-list))) (cond (element (soarpush (soarnth (cadr element) (soarnth (car element) data-matched)) new-condition)) (t (soarpush ' new-condition)))) ((eq (car condition) '<<) (prog nil l3 (soarpush (pop condition) new-condition) (and condition (neq (car new-condition) '>>) (go l3)))) (t (soarpush (pop condition) new-condition))) (cond ((eq current-goal (get (car new-condition) 'in-id-field)) (go l1))) (go l2))) (defun ops-back-trace (objects) (prog (wme goal) (setq *unbound-action-ids* nil) (cond ((and (not (numberp (car objects))) (get (car objects) 'goal-depth)) (setq goal (pop objects))) ((null objects) (setq goal (most-recent-subgoal *context-stack*)))) (cond ((null objects) (setq *created-list* (get goal 'created)) (find-subgoal-nonresults goal nil *created-list*) (soarmapcar #'(lambda (x) (back-trace-conditions goal x t)) (cond (*split-actions* (find-action-sets *subgoal-results* goal)) (t (list *subgoal-results*))))) (t (setq wme (conv-input-wme (pop objects))) (setq goal (cond ((null objects) (most-recent-subgoal *context-stack*)) (t (car objects)))) (setq *created-list* (get goal 'created)) (setq *subgoal-results* wme) (back-trace-conditions goal wme t))) (setq *created-list* nil) (setq *subgoal-results* nil) (soarprint " "))) (defun bind-it (action-list) (prog (variable-list) (setq variable-list (find-constant-ids action-list)) (setq *learn-ids* (append variable-list *learn-ids*)) (return variable-list))) (defun build-a-production (condition-list action-list wme-list) (prog (new-chunk) (cond ((null action-list) (soarwarn "No chunk was built because there were no actions" " ") (return nil)) ((> (length condition-list) *max-chunk-conditions*) (soarwarn "No chunk was built because *max-chunk-conditions* was exceeded:" (length condition-list)) (return nil))) l1 (setq *p-name* (soargenpname 'p)) (cond ((soarmemq *p-name* *pnames*) (go l1))) (setq *unbound* nil) (setq condition-list (nreverse (knotify-conditions (re-order-conditions condition-list)))) (and *unbound* (setq condition-list (re-order-conditions condition-list))) (setq new-chunk (list (list 'quote *p-name*) (list 'quote 'elaborate) (list 'quote (nconc (nconc condition-list (list '-->)) action-list)))) (cond ((cdrmember new-chunk *new-chunks*) (and *print-learn* (soarprintc "Duplicate chunk")) (return t))) (and *tracep* (soarpush *p-name* *tracep-list*)) (soarpush *p-name* *chunks*) (soarpush new-chunk *new-chunks*) (soarpush wme-list *wme-list-stack*) (return t))) (defun build-copies (duplicate) (build-a-production (append *condition-list* (soarmapcar #'cdr *copy-action-list*) (list (car duplicate))) (rebind-action-ids (cdr duplicate) *learn-ids*) nil)) (defun build-duplicates (action-list class-list duplicate-variable duplicates negations) (prog (cond-list condition dup-list class) (setq dup-list nil) (setq *action-list* (prune-actions action-list duplicate-variable)) (setq *condition-list* nil) (setq class-list (dremove 'goal-context-info class-list)) (soarpush 'goal-context-info class-list) l1 (setq class (pop class-list)) (cond ((null class) (cond ((null *action-list*) (setq *condition-list* *save-condition*) (setq *action-list* *save-action*) (return nil))) (setq *condition-list* (nreverse (append negations *condition-list*))) (return dup-list))) (setq cond-list (get class 'condition)) (soarputprop class nil 'condition) l2 (setq condition (pop cond-list)) (cond ((null condition) (go l1)) ((soarmemq condition duplicates) (soarpush (cons condition (dup-action condition)) dup-list)) (t (soarpush condition *condition-list*))) (go l2))) (defun build-terse (conditions) (prog (return-conditions change-flag element) (and *ltrace* (soarprinc "Conditions that are tersed out: ")) l0 (setq change-flag nil) (setq return-conditions nil) l1 (setq element (pop conditions)) (cond ((and (null element) change-flag) (setq conditions (nreverse return-conditions)) (go l0)) ((null element) (and *ltrace* (terpri (trace-file))) (return (nreverse return-conditions))) ((and (neq (class element) 'preference) (free-condition element)) (setq change-flag t) (and *ltrace* (ppline (car (p-conds-to-sp (list (clean-up-element element)))))) (untest (cdr element))) (t (soarpush element return-conditions))) (go l1))) (defun build-variable-list (element) (and element (get element 'in-id-field) (setq *learn-ids* (cons (cons element (soargenvar element)) *learn-ids*)))) (defun clean-up-action (action) (cons 'make (clean-up-clause action 'action))) (defun clean-up-clause (condition c-or-a) (prog (new-condition curpos att ppdat val class found-value element) (cond ((or (eq condition '-) (eq (cadr condition) '^)) (return condition))) (setq class (pop condition)) (setq found-value nil) (setq new-condition (list class)) (setq ppdat (get class 'ppdat)) (cond ((null ppdat) (setq ppdat (get 'state-info 'ppdat)))) (setq curpos 1) l1 (setq curpos (1+ curpos)) (cond ((null condition) (and found-value (return new-condition)) (return (nconc new-condition '(^ value nil))))) (setq element (pop condition)) (and (null element) (go l1)) (setq att (cdr (soarassq curpos ppdat))) (and (eq att 'value) (setq found-value t)) (or att (setq att curpos)) (and (eq att 'value) (setq found-value t)) (setq val (soarassq element *learn-ids*)) (cond (val (setq val (cdr val)) (and (eq c-or-a 'condition) (soarputprop val (1+ (or (get val 'tested) 0)) 'tested))) (t (setq val element))) (nconc new-condition (list '^ att val)) (go l1))) (defun clear-var-list nil (setq *learn-ids* nil) (soarmapc #'soarclearprops *used-var-list*) (soarmapc #'(lambda (x) (soarputprop x 1 'var-count)) *used-char-list*) (setq *used-var-list* nil)) (defun closure-preference (action subgoal) (and (test-preference-field (soarnth *goal-index* action) subgoal) (test-preference-field (soarnth *problem-space-index* action) subgoal) (test-preference-field (soarnth *state-index* action) subgoal) (test-preference-field (soarnth *operator-index* action) subgoal))) (defun compactify-conditions (condition-list action-list) (prog (class-list class-name same-class element duplicates duplicate-variable sclass negations) (setq duplicates nil) (setq *save-condition* condition-list) (setq *save-action* action-list) (setq negations nil) (setq class-list nil) (setq duplicate-variable nil) l1 (setq element (pop condition-list)) (cond ((null element) (return (build-duplicates action-list (reverse class-list) duplicate-variable duplicates negations))) ((eq element '-) (soarpush '- negations) (soarpush (pop condition-list) negations) (go l1))) (setq class-name (car element)) (setq same-class (get class-name 'condition)) (cond ((and (neq class-name 'preference) (free-condition element)) (setq same-class nil))) l4 (setq sclass (pop same-class)) (cond ((null sclass) (addprop class-name 'condition element) (and (not (soarmemq class-name class-list)) (soarpush class-name class-list)) (go l1))) (setq *suspected-duplicates* nil) (cond ((compare-conditions element sclass) (and (not (soarmemq sclass duplicates)) (soarpush sclass duplicates)) (setq duplicate-variable (append duplicate-variable *suspected-duplicates*)) (go l1))) (go l4))) (defun create-production nil (prog (chunk wme-list) (and (null *new-chunks*) (return)) (setq *new-chunks* (nreverse *new-chunks*)) (setq *wme-list-stack* (nreverse *wme-list-stack*)) l1 (cond ((null *new-chunks*) (setq *wme-list-stack* nil) (return))) (setq chunk (pop *new-chunks*)) (setq wme-list (pop *wme-list-stack*)) (eval (cons 'compile-production chunk)) (cond ((eq 1 *print-learn*) (terpri (trace-file)) (eval (list 'spm (cadar chunk)))) (*print-learn* (soarprintc "Build:") (soarprinc (cadar chunk)))) (refract-new-p chunk wme-list) (go l1))) (defun dup-action (condition) (prog (element action action-list return-list save-action) (setq action-list *action-list*) (setq *action-list* nil) (setq return-list nil) l1 (setq action (pop action-list)) (and (null action) (return return-list)) (cond ((eq (cadr action) 'preference) (soarpush action *action-list*) (go l1))) (setq save-action action) l2 (setq element (pop action)) (cond ((null element) (soarpush save-action *action-list*) (go l1)) ((and (variablep element) (soarmemq element (cddddr condition))) (soarpush save-action return-list) (go l1))) (go l2))) (defun find-action-closure (listx) (soarmapcar #'(lambda (x) (cdr (soarassq x *learn-ids*))) (find-closure listx))) (defun find-closure (listx) (cond ((null listx) listx) ((eq (car listx) '-) (find-closure (cddr listx))) (t (merge-not-time (cdar listx) (find-closure (cdr listx)))))) (defun find-constant-ids (action-list) (prog (action-ids element action) (setq action-ids nil) l1 (setq action (pop action-list)) (and (null action) (return action-ids)) (setq element (soarnth 4 action)) (cond ((and (not (variablep element)) (not (soarassq element action-ids))) (soarpush (cons element (soargenvar element)) action-ids))) (go l1))) (defun free-condition (elm1) (prog (carelm found-loser) (setq elm1 (cddddr elm1)) (setq found-loser nil) l1 (setq elm1 (cddr elm1)) (cond ((null elm1) (return found-loser))) (setq carelm (pop elm1)) (and (numberp carelm) (go l1)) (cond ((eq (get carelm 'tested) 1) (cond ((soarmemq carelm *action-closure*) (return nil)) (t (setq found-loser t))))) (go l1))) (defun get-cav-value (class attribute) (cdr (soarassq attribute (cdr (soarassq class *cav*))))) (defun get-cavi-id (class attribute value) (cdr (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*))))))) (defun knotify (val variables) (prog (result) (setq result nil) l1 (setq result (append result (list '<> (car variables)))) (setq variables (cdr variables)) (and variables (go l1)) (cond ((eq val ') (setq *unbound* t) (return (append result '(})))) (t (return (append result (list val '}))))))) (defun knotify-conditions (conditions) (prog (condition attribute return-conditions new-condition class value values id ids idds s-condition variable-list) (setq variable-list (setq return-conditions (setq *cav* (setq *cavi* (setq *variable-pairs* nil))))) l1 (setq condition (pop conditions)) (cond ((eq condition '-) (soarpush condition return-conditions) (go l1)) ((null condition) (setq *cav* (setq *cavi* nil)) (return return-conditions))) (setq s-condition condition) (setq new-condition (list (setq class (car condition)))) (setq condition (cddr condition)) (setq attribute 'worst) (setq id 'worst) l2 (cond ((eq (car condition) 'identifier) (setq id (cadr condition))) ((eq (car condition) 'attribute) (setq attribute (cadr condition))) ((eq (car condition) 'value) (setq value (cadr condition)) (cond ((variablep value) (setq values (get-cav-value class attribute)) (cond ((null values) (put-cav-attribute class attribute) (put-cav-value class attribute (list value)) (and (not (soarmemq value variable-list)) (soarpush value variable-list))) ((and (not (soarmemq value values)) (not (soarmemq value variable-list))) (put-cav-value class attribute (cons value values)) (setq new-condition (append new-condition '(^ value {) (knotify value values))) (soarpush (cons value values) *variable-pairs*) (setq variable-list (cons value variable-list)) (go l4)) ((not (soarmemq value values)) (put-cav-value class attribute (cons value values))))) ((and (neq id 'worst) (neq attribute 'worst) (neq value '{)) (setq ids (get-cavi-id class attribute value)) (setq idds (cons id ids)) (cond ((null ids) (put-cavi-attribute class attribute) (put-cavi-value class attribute value) (put-cavi-id class attribute value idds)) ((and (not (soarmemq id ids)) (not (soarassoc id *variable-pairs*))) (put-cavi-id class attribute value idds) (soarpush idds *variable-pairs*) (setq new-condition (append (list class '^ 'identifier '{) (knotify id ids) (list '^ 'attribute attribute '^ 'value value))) (go l4)))) ((eq value '{) (nconc new-condition (cons '^ condition)) (go l4))))) (nconc new-condition (list '^ (car condition) (cadr condition))) (setq condition (cdddr condition)) (and condition (go l2)) l4 (soarpush new-condition return-conditions) (go l1))) (defun ops-learn (z) (cond ((atom z) (print-status)) (t (cond ((eq (car z) 'on) (cond ((and *never-learn* (neq *cycle-count* 0)) (terpri (trace-file)) (soarprint "Error: Can not turn learning on. Must init-soar first")) (t (setq *learning* t) (setq *never-learn* nil)))) ((eq (car z) 'off) (cond ((and *never-learn* (neq *cycle-count* 0)) (terpri (trace-file)) (soarprint "Error: Can not turn learning to off. Must init-soar first")) (t (setq *learning* nil) (setq *never-learn* nil)))) ((eq (car z) 'never) (setq *learning* nil) (setq *never-learn* t)) ((eq (car z) 'full-print) (setq *print-learn* 1)) ((eq (car z) 'print) (setq *print-learn* 0)) ((eq (car z) 'noprint) (setq *print-learn* nil)) ((eq (car z) 'full-trace) (setq *ltrace* t) (setq *tracep* t)) ((eq (car z) 'trace) (setq *tracep* t) (setq *ltrace* nil)) ((eq (car z) 'notrace) (setq *tracep* nil) (setq *ltrace* nil)) ((eq (car z) 'always) (setq *always-learn* t)) ((eq (car z) 'bottom-up) (setq *always-learn* nil)) (t (terpri (trace-file)) (soarprint "Error: unknown option"))) (eval (cons 'learn (cdr z)))))) (defun learn-back-trace (old-context prior-context new-context subgoaled) (prog (return-value condition-list subgoal) (setq subgoal (get-current old-context 'goal)) (setq *created-list* (get subgoal 'created)) (setq *unbound-action-ids* nil) (soarmapc #'remove-from-wm (find-subgoal-nonresults subgoal (get-current prior-context 'goal) *created-list*)) (cond (*never-learn* (soarclearprops subgoal) (return t))) (setq return-value (soarmapcar #'(lambda (x) (handle-back-trace-actions x old-context prior-context new-context subgoaled)) (cond (*split-actions* (find-action-sets *subgoal-results* subgoal)) (t (list *subgoal-results*))))) (soarclearprops subgoal) (setq *subgoal-results* nil) (setq *learn-ids* nil) (return (t-in-list? return-value)))) (defun prune-actions (action-list duplicate-variable) (prog (action save-action return-list) (setq return-list nil) l1 (and (null action-list) (return return-list)) (setq action (pop action-list)) (setq save-action action) l2 (cond ((null action) (soarpush save-action return-list) (go l1)) ((soarmemq (pop action) duplicate-variable) (go l1))) (go l2))) (defun put-cav-attribute (class attribute) (cond ((soarassq class *cav*) (rplacd (soarassq class *cav*) (cons (list attribute) (cdr (soarassq class *cav*))))) (t (setq *cav* (cons (cons class (list (list attribute))) *cav*))))) (defun put-cav-value (class attribute value) (rplacd (soarassq attribute (cdr (soarassq class *cav*))) value)) (defun put-cavi-attribute (class attribute) (cond ((soarassq attribute (cdr (soarassq class *cavi*)))) ((soarassq class *cavi*) (rplacd (soarassq class *cavi*) (cons (list attribute) (cdr (soarassq class *cavi*))))) (t (setq *cavi* (cons (cons class (list (list attribute))) *cavi*))))) (defun put-cavi-id (class attribute value id) (rplacd (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*))))) id)) (defun put-cavi-value (class attribute value) (rplacd (soarassq attribute (cdr (soarassq class *cavi*))) (cons (list value) (cdr (soarassq attribute (cdr (soarassq class *cavi*))))))) (defun rebind-action-ids (action-list copy-list) (prog (element new-element return-list val val2) (setq return-list nil) l1 (and (null action-list) (return return-list)) (setq element (pop action-list)) (setq new-element nil) l2 (and (null element) (go l3)) (setq val2 (pop element)) (setq val (cdr (soarassq val2 copy-list))) (or val (setq val val2)) (soarpush val new-element) (go l2) l3 (soarpush (nreverse new-element) return-list) (go l1))) (defun refract-new-p (new-p wme-list) (prog (element prior-element) (setq prior-element nil) (setq new-p (cadar new-p)) l1 (cond ((setq element (soarassq new-p *conflict-set*)) (cond ((soarmemq element prior-element) (return t)) ((or (null wme-list) (test-subset (cdr element) wme-list)) (setq *conflict-set* (dremove element *conflict-set*))) (t (setq *conflict-set* (append (dremove element *conflict-set*) (list element))))) (soarpush element prior-element) (go l1)) (t (return t))))) (defun tersify-negations (negations) (prog (condition return-list new-condition id value) (setq return-list nil) l1 (cond ((null negations) (return return-list))) (setq condition (pop negations)) (setq new-condition (list (pop condition))) l2 (cond ((null condition) (setq new-condition (nreverse new-condition)) (and (soarmember new-condition return-list) (go l1)) (soarpush '- return-list) (soarpush new-condition return-list) (go l1))) (soarpush (pop condition) new-condition) (soarpush (pop condition) new-condition) (setq id (pop condition)) (cond ((eq 1 (get id 'tested)) (soarpush ' new-condition) (go l2)) (t (soarpush id new-condition) (go l2))))) (defun test-chunk-for-content (conditions) (prog (condition) l1 (cond ((null conditions) (soarwarn "No chunk was built because no conditions had a class in *chunk-classes*" " ") (clear-var-list) (return t))) (setq condition (pop conditions)) (cond ((eq condition '-) (go l1)) ((soarmemq (conv-type-to-sp (car condition)) *chunk-classes*) (return nil))) (go l1))) (defun ask-for-choice (choice-list) (prog (choice count) (setq *elapsed-time* (+ *elapsed-time* (- (alwaystime) *begin-time*))) (cond (*interlisp* (return (interlisp-menu choice-list)))) l1 (terpri (trace-file)) (soarprint "Choose from this list by position in list (1-n)") (setq count 1) (soarmapc #'(lambda (x) (soarprinc2 count ": ") (print-choice x) (setq count (1+ count))) choice-list) (princ "? " (trace-file)) (setq choice (read)) (cond ((and (numberp choice) (> choice 0) (< choice (1+ (length choice-list)))) (setq *begin-time* (alwaystime)) (return (soarnth (1- choice) choice-list)))) (soarprintc "Your answer was not a number between 1 and n.") (go l1))) (defun classify-decide (instance) (prog (pname node action goal slot value id id2 compared) (setq pname (car instance)) (setq *data-matched* (cdr instance)) (setq node (get pname 'topnode)) (init-var-mem (var-part node)) (init-ce-var-mem (ce-var-part node)) (setq action (cdddr (cadr (rhs-part node)))) (setq goal ($varbind (car action))) (setq action (cdddr action)) (setq id ($varbind (car action))) (setq action (cdddr action)) (setq slot ($varbind (car action))) (setq action (cdddr action)) (setq value ($varbind (car action))) (setq action (cdddr action)) (setq compared ($varbind (car action))) (cond ((eq value 'indifferent) (cond (compared (setq value 'equal)))) ((eq value 'better) (setq value 'worse) (setq id2 compared) (setq compared id) (setq id id2))) (addprop goal 'preferences (list slot value id compared (car *data-matched*))))) (defun decide-trace (arg) (setq *decide-trace* arg)) (defun decide-tracer (label list) (cond (*decide-trace* (terpri (trace-file)) (soarprinc3 " " label " ") (soarmapc #'print-id list)))) (defun decision-procedure (value-list current) (prog (new-values saved-values) (setq new-values (find-acceptable value-list)) (decide-tracer 'acceptable new-values) (cond ((null new-values) (cond ((and (neq current 'undecided) (null (prune-rejects (list (list current)) value-list current))) (return '(rejection)))) (return '(no-change)))) (setq new-values (process-indifferent new-values value-list)) (decide-tracer 'post-indifferent new-values) (setq new-values (set-equals new-values value-list)) (decide-tracer 'post-equal new-values) (setq new-values (prune-rejects new-values value-list current)) (decide-tracer 'post-reject new-values) (cond ((or (null new-values) (null (car new-values))) (return '(rejection)))) (setq saved-values new-values) (setq new-values (prune-worse new-values value-list)) (decide-tracer 'post-worse new-values) (and (null new-values) (return (cons 'conflict (soarsort (flatten saved-values))))) (and (null (car new-values)) (return (cons 'conflict (soarsort (flatten saved-values))))) (setq new-values (select-best new-values value-list)) (decide-tracer 'post-best new-values) (setq new-values (set-worst new-values value-list)) (decide-tracer 'post-worst new-values) (and (cdr new-values) (return (test-parallel (soarsort (flatten new-values)) value-list 'tie))) (return (test-parallel new-values value-list nil)))) (defun find-acceptable (value-list) (dremove 'nil (flatten (find-all-assq 'acceptable value-list)))) (defun find-all-assq (item alist) (prog (alist2 element) (setq alist2 nil) l1 (and (null alist) (return alist2)) (setq element (pop alist)) (cond ((and (eq item (car element)) (not (soarmember (cdr element) alist2))) (soarpush (cdr element) alist2))) (go l1))) (defun find-goal-preferences (context) (get (car context) 'preferences)) (defun find-no-change-slot (context) (cond ((eq (cadr context) 'undecided) 'goal) ((eq (caddr context) 'undecided) 'problem-space) ((eq (cadddr context) 'undecided) 'state) (t 'operator))) (defun find-preference (data) (prog nil l1 (cond ((null data) (return nil)) ((eq (caar data) 'preference) (return (car data)))) (setq data (cdr data)) (go l1))) (defun find-worse (x ylist) (cond ((null ylist) nil) ((soarmemq x (car ylist)) t) (t (find-worse x (cdr ylist))))) (defun make-info (info goal-id attribute value) (prog (array) (setq array (list info goal-id attribute value)) (add-to-wm array) (return array))) (defun process-decide (phase-set) (accum-stats) (setq *new-chunks* nil) (soarmapcar #'classify-decide phase-set) (process-context-stack *context-stack*)) (defun process-indifferent (new-values value-list) (prog (worst-set return-list new-equals old-equals worst-list item) (setq worst-list (find-all-assq 'indifferent value-list)) (setq new-equals nil) (setq return-list nil) l1 (cond ((null new-values) (and new-equals (return (cons new-equals return-list))) (return return-list))) (setq old-equals (pop new-values)) (cond ((soarassq old-equals worst-list) (soarpush old-equals new-equals)) (t (soarpush (list old-equals) return-list))) (go l1))) (defun process-results (results id) (cond ((null (cdr results)) (car results)) ((soarmemq id results) id) ((eq *select-equal* 'first) (car results)) ((soarlistp *select-equal*) (cond ((find-selected-result (pop *select-equal*) results)) (t (setq *select-equal* t) (ask-for-choice results)))) (*select-equal* (ask-for-choice results)) (t (soarnth (random (1- (length results))) results)))) (defun prune-rejects (new-values value-list current) (prog (return-list reject-list new-value new-value-list) (setq reject-list (dremove 'nil (flatten (find-all-assq 'reject value-list)))) (setq return-list nil) l1 (cond ((null new-values) (cond ((and (null return-list) (eq current 'undecided)) (return nil)) ((and (null return-list) (soarlistp current)) (return (list (soarmapc #'(lambda (x) (setq current (remove x current))) reject-list)))) ((and (null return-list) (not (soarmemq current reject-list))) (return (list current)))) (return return-list))) (setq new-value (pop new-values)) (setq new-value-list nil) l2 (cond ((null new-value) (and new-value-list (soarpush new-value-list return-list)) (go l1)) ((not (soarmemq (car new-value) reject-list)) (soarpush (car new-value) new-value-list))) (pop new-value) (go l2))) (defun prune-remove (remove-list) (prog (non-context-list wme) (setq non-context-list nil) l1 (and (null remove-list) (return (nreverse non-context-list))) (setq wme (pop remove-list)) (cond ((and (eq (class wme) 'goal-context-info) (soarmemq (sattribute wme) '(problem-space state operator))) (remove-from-wm wme)) (t (soarpush wme non-context-list))) (go l1))) (defun prune-worse (new-values value-list) (prog (equal-set return-list equals old-equals old-values item item2 worse-list hit worse-list2) (setq worse-list (find-all-assq 'worse value-list)) (setq return-list nil) (setq old-values new-values) l1 (and (null new-values) (return return-list)) (setq old-equals (setq equal-set (pop new-values))) (setq equals nil) l2 (cond ((null equal-set) (soarpush equals return-list) (go l1))) (setq item (pop equal-set)) (setq worse-list2 worse-list) l4 (cond ((null worse-list2) (soarpush item equals) (go l2))) (setq item2 (pop worse-list2)) (cond ((and (eq (car item2) item) (neq item (cadr item2))) (setq hit (cadr item2)) (cond ((soarmemq hit old-equals) (go l2)) ((find-worse hit old-values) (go l1))))) (go l4))) (defun select-best (new-values value-list) (prog (return-list equal-list old-values best-list save-e-list e-item) (setq best-list (find-all-assq 'best value-list)) (setq return-list nil) (setq old-values new-values) l1 (and (null new-values) (null return-list) (return old-values)) (and (null new-values) (return (list return-list))) (setq equal-list (pop new-values)) (setq save-e-list equal-list) l2 (and (null equal-list) (go l1)) (setq e-item (pop equal-list)) (cond ((soarassq e-item best-list) (soarpush e-item return-list))) (go l2))) (defun user-select (x) (setq *select-equal* x)) (defun set-equals (new-values value-list) (prog (equal-set new-equals return-list hit hit-list old-hit-list equal-list equal-list2) (setq equal-list (find-all-assq 'equal value-list)) (setq return-list nil) (setq new-equals (pop new-values)) (setq equal-set nil) (setq old-hit-list nil) (setq hit-list nil) l2 (cond ((null new-equals) (and equal-set (soarpush equal-set return-list)) (and (null new-values) (return return-list)) (setq old-hit-list (append old-hit-list hit-list)) (setq new-equals (pop new-values)) (setq equal-set nil) (cond ((soarmemq (car new-equals) old-hit-list) (pop new-equals) (go l2))))) (setq equal-list2 equal-list) l4 (cond ((null equal-list2) (soarpush (pop new-equals) equal-set) (go l2))) (cond ((equal (caar equal-list2) (car new-equals)) (setq hit (cadar equal-list2)) (cond ((and (not (soarmemq hit equal-set)) (not (soarmemq hit new-equals)) (soarmemq hit (flatten new-values))) (setq new-equals (append new-equals (list hit))) (soarpush hit hit-list))))) (pop equal-list2) (go l4))) (defun set-worst (new-values value-list) (prog (worst-set return-list new-equals old-equals worst-list item) (setq worst-list (find-all-assq 'worst value-list)) (setq return-list nil) l1 (and (null new-values) (null return-list) (return (list worst-set))) (and (null new-values) (return return-list)) (setq old-equals (pop new-values)) (setq new-equals nil) l2 (cond ((null old-equals) (and new-equals (soarpush new-equals return-list)) (go l1))) (setq item (pop old-equals)) (cond ((soarassq item worst-list) (soarpush item worst-set)) (t (soarpush item new-equals))) (go l2))) (defun test-parallel (results value-list difficulty) (prog (parallel-list parallel-results new-results) (setq parallel-list (find-all-assq 'parallel value-list)) (setq results (flatten results)) (and (null parallel-list) (return (cons difficulty results))) (setq parallel-results (list (car results))) (setq new-results (cdr results)) l1 (cond ((null new-results) (decide-tracer 'parallel results) (return (cons 'parallel results)))) (cond ((soarmember (list (car new-results) (car parallel-results)) parallel-list) (soarpush (pop new-results) parallel-results) (go l1)) (t (return (cons difficulty results)))))) (defun change-context (difficulty results old-context slot context-stack preferences) (prog (new-context subgoaled) (cond ((and *wtrace* (cdr context-stack) (trace-problem-space?)) (soarprintc "--Removal Phase--"))) (setq new-context (create-new-context difficulty results old-context slot)) (setq subgoaled (soarmapcar #'(lambda (x) (process-sub-contexts x new-context old-context)) (cdr context-stack))) (cond ((t-in-list? subgoaled) (rplaca (soarnthcdr 9 old-context) t) (rplaca (soarnthcdr 9 new-context) t))) (cond ((and *wtrace* (trace-problem-space?)) (soarprintc "--Decision Phase--"))) (cond (difficulty (write-trace " " difficulty slot) (create-production) (cond ((and (eq difficulty 'no-change) (soarlistp results)) (rplacd context-stack (soarmapcar #'(lambda (x) (create-goal-context difficulty slot x old-context preferences)) results))) (t (rplacd context-stack (list (create-goal-context difficulty slot results old-context preferences))))) (return new-context)) (t (write-trace " DECIDE " slot results) (rplacd context-stack nil) (change-to-new-context new-context old-context preferences) (return new-context))))) (defun change-to-new-context (new-context old-context preferences) (prog (slots new-contexts slot depth context-changes) (setq slots '(operator state problem-space)) (setq new-contexts nil) (setq *p-name* 'decision-procedure) (setq *context* new-context) (setq depth (get-context-depth new-context)) (setq context-changes nil) l1 (setq slot (pop slots)) (cond ((null slot) (create-production) (soarmapc #'(lambda (x) (trace-object (car x) (cdr x) depth)) context-changes) (soarmapc #'(lambda (x) (cond ((neq (svalue x) 'undecided) (setq *data-matched* (list (find-acceptable-preference preferences (svalue x)))) (setq *first-action* t)) (t (setq *data-matched* nil) (setq *first-action* t))) (add-to-wm x)) new-contexts) (return)) ((neq (get-current new-context slot) (get-current old-context slot)) (setq new-contexts (nconc (remove-current (get-current old-context 'goal) slot (get-current old-context slot) (get-current new-context slot)) new-contexts)) (soarpush (cons slot (get-current new-context slot)) context-changes))) (go l1))) (defun context-stack nil (soarmapc #'print *context-stack*) t) (defun create-goal-context (desired slot results context preferences) (prog (goal-id created-list result superoperator temp supergoal) (setq *p-name* 'decision-procedure) (setq *data-matched* nil) (setq supergoal (get-current context 'goal)) (setq goal-id (soargensym 'g)) (soarputprop goal-id (1+ (get supergoal 'goal-depth)) 'goal-depth) (setq *context* (list goal-id 'undecided 'undecided 'undecided 0 nil nil nil results nil (1+ (get-context-depth context)))) (setq created-list (list (make-info 'goal-context-info goal-id 'problem-space 'undecided) (make-info 'goal-context-info goal-id 'supergoal supergoal) (make-info 'goal-context-info goal-id 'state 'undecided) (make-info 'goal-context-info goal-id 'operator 'undecided) (make-info 'goal-context-info goal-id 'choices (cond ((or (eq desired 'no-change) (eq desired 'rejection)) 'none) (t 'multiple))))) (cond ((eq desired 'rejection) (setq slot (cadr (soarmemq slot '(operator state problem-space goal)))) (create-goal-info (find-reject-preferences preferences) goal-id))) (nconc created-list (list (make-info 'goal-context-info goal-id 'impasse desired))) (setq superoperator 'undecided) (setq temp nil) (cond ((eq desired 'no-change) (cond ((eq slot 'operator) (setq superoperator results)) ((eq slot 'state) (setq temp (list (list 'goal-context-info supergoal 'operator 'undecided)))) ((eq slot 'problem-space) (setq temp (list (list 'goal-context-info supergoal 'state 'undecided)))) ((eq slot 'goal) (setq temp (list (list 'goal-context-info supergoal 'problem-space 'undecided))))))) (create-goal-info temp goal-id) (nconc created-list (list (make-info 'goal-context-info goal-id 'role slot))) (create-goal-info (list (list 'goal-context-info supergoal 'operator superoperator)) goal-id) (nconc created-list (list (make-info 'goal-context-info goal-id 'superoperator superoperator))) l4 (cond ((or (not results) (atom results)) (soarputprop goal-id created-list 'created) (trace-object 'goal goal-id (1+ (get-context-depth context))) (return (list *context*)))) (setq result (pop results)) (cond ((eq slot 'state) (create-goal-info (list (list 'goal-context-info supergoal 'operator (get-current context 'operator)) (find-acceptable-preference preferences result)) goal-id)) (t (create-goal-info (list (find-acceptable-preference preferences result)) goal-id))) (nconc created-list (list (make-info 'goal-context-info goal-id 'item result))) (go l4))) (defun create-new-context (difficulty result old-context slot) (prog (slots found-slot aslot return-list) (cond (difficulty (return (list (get-current old-context 'goal) (get-current old-context 'problem-space) (get-current old-context 'state) (get-current old-context 'operator) (get-context-pnumber old-context) slot difficulty result (get-context-super-operator old-context) (get-context-subgoaled old-context) (get-context-depth old-context))))) (setq slots '(goal problem-space state operator)) (setq return-list nil) (setq found-slot nil) l1 (setq aslot (pop slots)) (cond ((null aslot) (return (append return-list (list (get-context-pnumber old-context) nil nil nil (get-context-super-operator old-context) (get-context-subgoaled old-context) (get-context-depth old-context)))))) (cond (found-slot (setq return-list (append return-list '(undecided)))) ((eq aslot slot) (setq found-slot t) (setq return-list (append return-list (list result)))) (t (setq return-list (append return-list (list (get-current old-context aslot)))))) (go l1))) (defun get-context-depth (context) (soarnth 10 context)) (defun get-context-difficulty (context) (soarnth 6 context)) (defun get-context-pnumber (context) (soarnth 4 context)) (defun get-context-results (context) (soarnth 7 context)) (defun get-context-slot (context) (soarnth 5 context)) (defun get-context-subgoaled (context) (soarnth 9 context)) (defun get-context-super-operator (context) (soarnth 8 context)) (defun get-current (context slot) (soarnth (cdr (soarassq slot '((goal . 0) (problem-space . 1) (state . 2) (operator . 3)))) context)) (defun init-context (problem-space state operator) (prog (goal-name) (init-soar) (setq goal-name (soargensym 'g)) (setq *context* (list goal-name problem-space state operator '0 'nil 'nil 'nil 'nil 'nil '0)) (setq *context-stack* (list *context*)) (return goal-name))) (defun neq-result (difficulty result context slot) (cond (difficulty (or (neq difficulty (get-context-difficulty context)) (neq slot (get-context-slot context)) (not (test-results-subset result context)))) ((soarlistp result) (not (test-slot-subset result context))) (t (neq result (get-current context slot))))) (defun process-a-parallel-operator (context-stack results prior-context) (prog nil (and (soarmemq (get-context-super-operator (car context-stack)) results) (return (list context-stack))) (process-sub-contexts context-stack prior-context prior-context) (return nil))) (defun process-context (context context-stack) (prog (context-preferences slot-preferences preferences slots slot ids results difficulty pnumber current) (setq context-preferences (find-goal-preferences context)) (remprop (car context) 'preferences) (setq pnumber (length context-preferences)) (rplaca (soarnthcdr 4 context) pnumber) (setq slots '(problem-space state operator)) (setq ids (cdr context)) l1 (setq current (pop ids)) (setq slot (pop slots)) (cond ((null slot) (setq difficulty 'no-change) (setq slot (find-no-change-slot context)) (setq current (get-current context slot)) (cond ((neq-result difficulty nil context slot) (rplaca context-stack (change-context difficulty current context slot context-stack nil)) (return t)) ((and (eq slot 'operator) (soarlistp current)) (process-parallel-operators context context-stack) (return nil)) (t (return nil))))) (setq slot-preferences (find-all-assq slot context-preferences)) (setq preferences (soarmapcar #'(lambda (x) (car (reverse x))) slot-preferences)) (setq slot-preferences (soarmapcar #'(lambda (x) (reverse (cdr (reverse x)))) slot-preferences)) (cond (*decide-trace* (soarprintc slot) (soarprinc " ") (print-id current))) (setq results (decision-procedure slot-preferences current)) (setq difficulty (pop results)) (cond ((eq difficulty 'no-change) (go l1)) ((not difficulty) (setq results (process-results results current))) ((eq difficulty 'parallel) (setq difficulty nil))) (cond ((neq-result difficulty results context slot) (and (broken2 results) (setq *remaining-decide* 0)) (rplaca context-stack (change-context difficulty results context slot context-stack preferences)) (return t)) (difficulty (return)) ((eq results 'undecided) (setq slots nil))) (go l1))) (defun process-context-stack (context-stack) (prog (context) (setq context (car context-stack)) (cond ((null (cdr context-stack)) (process-context context context-stack) (check-limits) (return)) ((test-context context) (cond ((process-context context context-stack) (check-limits) (return)))) (t (remprop (car context) 'preferences))) (soarmapc #'(lambda (x) (process-context-stack x)) (cdr context-stack)))) (defun process-parallel-operators (context context-stack) (rplacd context-stack (soarmapconc #'(lambda (x) (process-a-parallel-operator x (get-current context 'operator) context)) (cdr context-stack))) (create-production)) (defun process-sub-contexts (context-stack new-context prior-context) (prog (old-context subgoaled) (setq old-context (car context-stack)) (setq subgoaled nil) (cond ((cdr context-stack) (setq subgoaled (t-in-list? (soarmapcar #'(lambda (x) (process-sub-contexts x old-context old-context)) (cdr context-stack)))))) (return (learn-back-trace old-context prior-context new-context subgoaled)))) (defun push-context-stack (context) (soarpush context *context-stack*) (setq *context* context)) (defun test-context (context) (neq (length (find-goal-preferences context)) (get-context-pnumber context))) (defun test-if-subset (subset set) (cond ((null subset) t) ((atom set) nil) ((soarmemq (car subset) set) (test-if-subset (cdr subset) set)) (t nil))) (defun test-results-subset (result context) (cond (*impasse-subset-not-equal* (equal result (get-context-results context))) ((test-if-subset result (get-context-results context)) (rplaca (soarnthcdr 7 context) result) t) (t nil))) (defun test-slot-subset (result context) (cond ((test-if-subset result (get-current context 'operator)) (rplaca (soarnthcdr 3 context) result) t) (t nil))) (defun all-bound? (vlist) (soar-do ((vl1 vlist (cdr vl1))) ((null vl1) t) (cond ((not (bound-var? (car vl1))) (return nil))))) (defun bound-preference? (pr) (all-bound? (get-context-vars-in-pref pr))) (defun bound-var? (v) (get v 'bound)) (defun check-negations (set-vars negations) (soar-do ((neg negations (cddr neg)) (active) (unactive)) ((null neg) (cons active unactive)) (cond ((all-bound? (get-all-vars-in-neg (car neg))) (soarpush '- active) (soarpush (strip-condition (car neg)) active)) (t (soarpush '- unactive) (soarpush (car neg) unactive))))) (defun classify (set-vars dup-vars conditions flag) (prog (attr-type attr-val val-type val-val temp c i mini result) (setq mini 102) l1 (setq c (pop conditions)) (cond ((null c) (return (rplnode *global-pair* mini (nreverse result)))) ((setq i (get-prev-rank c)) (cond (i (go l2)))) ((eq (get-condition-type c) 'preference) (cond ((and (soarmemq 'role (cdr c)) (eq 'operator (cadr (soarmemq 'role (cdr c))))) (setq i (+ 6 *default-multi*))) (t (setq i 3))) (and flag (put-rank c i))) (t (setq temp (get-attr-val-types c)) (setq attr-type (caar temp)) (setq val-type (cadr temp)) (setq attr-val (cdar temp)) (setq val-val (cddr temp)) (cond ((and (eq attr-type 'var) (bound-var? attr-val)) (setq attr-type 'set-var))) (cond ((and (eq val-type 'var) (bound-var? val-val)) (setq val-type 'set-var))) (cond ((and (eq attr-type 'const) (eq val-type 'const)) (setq i 1) (put-rank c 1)) ((and (soarmemq attr-type '(const set-var)) (soarmemq val-type '(const set-var))) (setq i 2) (and flag (put-rank c 2))) ((eq (get-condition-type c) 'goal-context-info) (cond ((eq (get-mult-num (get-condition-type c) attr-val) 1) (setq i 4)) (t (setq i 5))) (put-rank c i)) ((and (eq attr-type 'const) (eq val-type 'var) (soarmemq val-val dup-vars)) (setq i (+ 6 (get-mult-num (get-condition-type c) attr-val)))) ((and (soarmemq attr-type '(var set-var)) (soarmemq attr-val dup-vars) (soarmemq val-type '(var set-var)) (soarmemq val-val dup-vars)) (setq i 100)) (t (setq i 101) (put-rank c 101))))) l2 (cond ((< i mini) (setq mini i) (setq result (list c))) ((= i mini) (soarpush c result))) (go l1))) (defun classify-match-elt (x) (cond ((eq (car x) '<<) (rplnode *global-pair* (skip-disjunction x) '(other))) ((predicatep (car x)) (rplnode *global-pair* (next-sym (next-sym x)) '(other))) ((variablep (car x)) (rplnode *global-pair* (next-sym x) (cons 'var (car x)))) ((eq (car x) '//) (rplnode *global-pair* (next-sym x) (cons 'const (cadr x)))) (t (rplnode *global-pair* (next-sym x) (cons 'const (car x)))))) (defun classify-term (x) (prog (result) (setq result '(other)) (cond ((eq (car x) '{) (return (prog (next-elt) (setq x (cdr x)) loop (cond ((eq (car x) '}) (return (rplnode *global-pair* (cdr x) result))) (t (setq next-elt (pop-match-elt x)) (cond ((soarmemq (car next-elt) '(var const)) (setq result next-elt))) (go loop)))))) (t (return (classify-match-elt x)))))) (defun find-all-vars-in-condition (condition) (soar-do ((c (cdddr condition)) (vars) (next-elt)) ((null c) vars) (cond ((variablep (car c)) (soarpush (car c) vars) (setq c (next-sym c))) ((eq (car c) '<<) (setq c (skip-disjunction c))) (t (setq c (next-sym c)))))) (defun find-best-condition (set-vars dup-vars active-conditions un-active-conditions ccl recurse-level minsofar) (prog (ccl1 i c tie-conds minc minrank temp new-vars act-conds un-act-conds s-v best) (setq i (car ccl)) (setq tie-conds (cdr ccl)) (cond ((> i 101) (return nil)) ((or (<= i 6) (= i 101) (and (null (cdr tie-conds)) (or (not (= i 7)) (= recurse-level 0))) (= recurse-level *max-recurse*)) (setq c (car tie-conds)) (return (cons (list i) c)))) (setq minrank '(102)) (cond ((and minsofar (or (> i (car minsofar)) (and (= i (car minsofar)) (cdr minsofar) (= 1 (cadr minsofar))))) (return '((100))))) l2 (setq c (pop tie-conds)) (and (null c) (go l3)) (setq temp (get-attr-val-types c)) (cond ((eq (cadr temp) 'const) (setq new-vars (list (cdar temp)))) (t (setq new-vars (list (cddr temp))))) (setq act-conds (remove c active-conditions)) (setq s-v (mark-as-set new-vars)) (setq temp (get-conditions-with-vars s-v un-active-conditions)) (setq act-conds (append (car temp) act-conds)) (setq un-act-conds (cdr temp)) (setq ccl1 (classify s-v dup-vars act-conds nil)) (setq best (find-best-condition s-v dup-vars act-conds un-act-conds ccl1 (+ 1 recurse-level) (cdr minrank))) (unmark-as-set s-v) (cond ((or (and (equal (car best) minrank) (eq (get-id-var c) *last-value-var*)) (lexless (car best) minrank)) (setq minrank (car best)) (setq minc c))) (cond ((eq (car minrank) 1) (go l3))) (go l2) l3 (return (cons (cons i minrank) minc)))) (defun find-info-on-cond (c flag) (prog (label attr val id vars next-term prefvars) (setq attr '(const)) (setq val '(const)) (setq c (cdr c)) l1 (setq c (cdr c)) (cond ((null c) (cond (flag (return (list id vars prefvars nil))) (t (return (list id vars (cons attr val) nil)))))) (setq label (pop c)) (setq next-term (pop-term c)) (cond ((eq (car next-term) 'var) (soarpush (cdr next-term) vars))) (cond ((and flag (soarmemq label '(goal problem-space state operator)) (eq (car next-term) 'var) (soarpush (cdr next-term) prefvars)))) (cond ((eq label 'identifier) (cond ((eq (car next-term) 'const) (soarwarn "Constant identifier field in: " c) (setq id 'const)) ((eq (car next-term) 'other) (soarwarn "Identifier field not constant or variable in: " c) (setq id nil)) (t (setq id (cdr next-term))))) ((eq label 'object) (cond ((eq (car next-term) 'const) (soarwarn "Constant object field in: " c) (setq id 'const)) ((eq (car next-term) 'other) (soarwarn "Object field not constant or variable in: " c) (setq id nil)) (t (setq id (cdr next-term))))) ((eq label 'attribute) (setq attr next-term)) ((eq label 'value) (setq val next-term))) (go l1))) (defun find-pred-vars-in-condition (c) (soar-do ((type) (varlist)) ((null c) varlist) (cond ((predicatep (car c)) (setq c (next-sym c)) (setq type (pop-match-elt c)) (cond ((eq (car type) 'var) (setq varlist (cons (cdr type) varlist))))) ((eq (car c) '<<) (setq c (skip-disjunction c))) (t (setq c (next-sym c)))))) (defun get-all-vars-in-neg (neg) (car neg)) (defun get-attr-val-types (x) (cadr (cddar x))) (defun get-condition-type (c) (cadr c)) (defun get-conditions-with-vars (vars cl) (cond ((null vars) nil) (t (soar-do ((cl1 cl (cdr cl1)) (result-with) (result-wo) (id)) ((null cl1) (cons (nreverse result-with) (nreverse result-wo))) (setq id (get-id-var (car cl1))) (cond ((and (or (and (not (eq (get-condition-type (car cl1)) 'preference)) (bound-var? id)) (eq id 'const) (and (eq (get-condition-type (car cl1)) 'preference) (bound-preference? (car cl1)))) (no-unbound-predicates? vars (car cl1))) (soarpush (car cl1) result-with)) (t (soarpush (car cl1) result-wo))))))) (defun get-context-vars-in-pref (pr) (cadr (cddar pr))) (defun get-id-var (c) (cadr (car c))) (defun get-mult-num (type attr) (soar-do ((l *multi-attribute* (cdr l))) ((null l) 1) (cond ((and (eq (caar l) type) (eq (cadar l) attr)) (cond ((car (cddar l)) (return (car (cddar l)))) (t (return *default-multi*))))))) (defun get-pred-vars-in-condition (c) (car (car c))) (defun get-prev-rank (c) (car (cddddr (car c)))) (defun get-twice-used-vars (cl) (prog (varlist dup-vars) (soar-do ((cl1 cl (cdr cl1))) ((null cl1)) (setq varlist (append (get-pred-vars-in-condition (car cl1)) (append (get-vars-in-condition (car cl1)) varlist)))) (soar-do ((vl varlist (cdr vl))) ((null vl)) (cond ((and (soarmemq (car vl) (cdr vl)) (not (soarmemq (car vl) dup-vars))) (soarpush (car vl) dup-vars)))) (return dup-vars))) (defun get-vars-in-condition (c) (caddr (car c))) (defun insert-ne-undec (c2 dup-vars) (prog (undecflag braceflag c1 var label c x) (setq c c2) (setq c (cdr c)) l1 (cond ((null c) (return c2))) (setq undecflag nil) (setq braceflag nil) (setq var nil) (pop c) (setq label (pop c)) (cond ((and (eq label 'attribute) (not (soarmemq (car c) '(problem-space state operator)))) (return c2))) (setq c1 c) l2 (setq x (car c)) (cond ((eq x '{) (setq braceflag t) (pop c)) ((and (eq x '<>) (eq (cadr c) 'undecided)) (setq undecflag t) (pop c) (pop c)) ((and (not undecflag) (not (eq label 'identifier)) (not (eq label 'object)) (variablep x) (not (soarmemq x dup-vars))) (setq var x) (pop c)) ((eq x '}) (go l3)) (t (pop-match-elt c))) (cond (braceflag (go l2))) l3 (cond ((and var (not undecflag)) (cond (braceflag (rplacd c1 (append '(<> undecided) (cdr c1)))) (t (rplacd c1 (append '(<> undecided) (cons x (cons '} (cdr c1))))) (rplaca c1 '{))))) (go l1))) (defun lexless (a b) (soar-do ((a1 a (cdr a1)) (b1 b (cdr b1))) ((null a1) t) (cond ((null a1) (return t)) ((null b1) (return nil)) ((< (car a1) (car b1)) (return t)) ((< (car b1) (car a1)) (return nil))))) (defun mark-as-set (vlist) (cond ((or (null vlist) (equal vlist '(nil))) nil) (t (soar-do ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1)) (result)) ((null vl1) result) (cond ((and (atom (car vl1)) (not (get (car vl1) 'bound))) (soarputprop (car vl1) t 'bound) (soarpush (car vl1) result))))))) (defun next-sym (x) (cond ((eq (car x) '//) (cddr x)) (t (cdr x)))) (defun no-unbound-predicates? (vars c) (all-bound? (get-pred-vars-in-condition c))) (defun predicatep (x) (and (symbolp x) (get x 'predicate))) (defun put-rank (c n) (rplaca (cddddr (car c)) n)) (defun re-order-conditions (cl) (prog (un-active-conditions new-conditions set-vars dup ccl best active-conditions negations temp already-no-active-conditions) (cond ((null cl) (return nil))) (setq cl (sort-conditions cl)) (setq *last-value-var* nil) (setq negations (cadr cl)) (setq cl (car cl)) (setq dup (get-twice-used-vars cl)) (setq un-active-conditions cl) (setq active-conditions nil) (go l4) l0 (cond ((null un-active-conditions) (cond (negations (soar-do nil ((null negations)) (soarpush '- new-conditions) (soarpush (strip-condition (car negations)) new-conditions) (setq negations (cddr negations))))) (unmark-as-set set-vars) (setq *condition-vars* set-vars) (return (nreverse new-conditions))) ((or already-no-active-conditions (neq 'goal-context-info (get-condition-type (car un-active-conditions)))) (soarpush (strip-condition (car un-active-conditions)) new-conditions) (setq un-active-conditions (cdr un-active-conditions)) (setq already-no-active-conditions nil) (cond ((neq (class (car new-conditions)) 'preference) (soarwarn " Condition not linked to previous conditions " (car (p-to-sp (list (car new-conditions))))))) (go l0))) l4 (setq already-no-active-conditions t) (setq set-vars (append (mark-as-set (get-id-var (car un-active-conditions))) set-vars)) l3 (setq temp (get-conditions-with-vars set-vars un-active-conditions)) (setq active-conditions (append (car temp) active-conditions)) (setq un-active-conditions (cdr temp)) l1 (cond ((null active-conditions) (go l0))) (setq ccl (classify set-vars dup active-conditions t)) (setq best (find-best-condition set-vars dup active-conditions un-active-conditions ccl 0 nil)) (setq already-no-active-conditions nil) (cond ((null best) (go l0))) (cond (*order-trace* (progn (soarprint (cons (car best) (strip-condition (cdr best))))))) (setq best (cdr best)) (setq active-conditions (dremove best active-conditions)) l2 (setq set-vars (append (mark-as-set (get-vars-in-condition best)) set-vars)) (setq temp (get-attr-val-types best)) (cond ((eq (cadr temp) 'var) (setq *last-value-var* (cddr temp))) (t (setq *last-value-var* nil))) (setq temp (strip-condition best)) (cond ((eq (get-condition-type best) 'goal-context-info) (insert-ne-undec temp dup))) (soarpush temp new-conditions) (setq temp (check-negations set-vars negations)) (setq new-conditions (append (car temp) new-conditions)) (setq negations (cdr temp)) (go l3))) (defun reorder-p-conds (spxs) (prog (type conds action) (pop spxs) (setq *p-name* (pop spxs)) (setq type (cond ((or (eq (car spxs) 'elaborate-once) (eq (car spxs) 'elaborate) (eq (car spxs) 'decide)) (pop spxs)) (t 'elaborate))) (setq conds nil) condloop (soarpush (pop spxs) conds) (cond ((and spxs (neq (car spxs) '-->)) (go condloop))) (setq action spxs) (setq spxs (append (re-order-conditions (nreverse conds)) spxs)) (test-connected-actions action) (soarpush type spxs) (soarpush *p-name* spxs) (soarpush 'p spxs) (return spxs))) (defun skip-disjunction (x) (soar-do nil ((eq (car x) '>>) (cdr x)) (setq x (next-sym x)))) (defun sort-conditions (cl) (prog (regulars c negations goal-contexts) (setq negations nil) (setq regulars nil) (setq goal-contexts nil) l1 (setq c (pop cl)) (cond ((null c) (return (list (append (nreverse goal-contexts) (nreverse regulars)) (nreverse negations)))) ((eq c '-) (setq c (pop cl)) (soarpush (cons (find-all-vars-in-condition c) c) negations) (unmark-as-set (get-all-vars-in-neg (car negations))) (soarpush '- negations)) ((eq (car c) 'preference) (soarpush (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c 'preference)) c) regulars) (unmark-as-set (get-pred-vars-in-condition (car regulars))) (unmark-as-set (get-vars-in-condition (car regulars)))) ((eq (car c) 'goal-context-info) (soarpush (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil)) c) goal-contexts) (unmark-as-set (get-pred-vars-in-condition (car goal-contexts))) (unmark-as-set (get-vars-in-condition (car goal-contexts)))) (t (soarpush (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil)) c) regulars) (unmark-as-set (get-pred-vars-in-condition (car regulars))) (unmark-as-set (get-vars-in-condition (car regulars))))) (go l1))) (defun strip-condition (x) (cond ((atom x) x) (t (cdr x)))) (defun unmark-as-set (vlist) (soar-do ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1))) ((null vl1) vlist) (remprop (car vl1) 'bound))) (start-soar) (terpri) cmucl-21a/src/bootfiles/000077500000000000000000000000001260377556400153365ustar00rootroot00000000000000cmucl-21a/src/bootfiles/18c/000077500000000000000000000000001260377556400157315ustar00rootroot00000000000000cmucl-21a/src/bootfiles/18c/README000066400000000000000000000007061260377556400166140ustar00rootroot00000000000000This directory holds any special "boot" files needed to get from some delta to the next. The directory src/bootfiles/18c holds files generated post 18c release. The files will be named boot1.lisp, boot2.lisp, ..., bootz.lisp. Each file should have some commentary as to the particulars about the file. It is hoped, but not guaranteed, that one could load all files into a fresh 18c or nearly current environment and be able to compile current sources. cmucl-21a/src/bootfiles/18c/boot1.lisp000066400000000000000000000002321260377556400176430ustar00rootroot00000000000000;;; Needed to compile post PPC backend inclusion. (in-package "C") (export 'ppc-fasl-file-implementation) (defconstant ppc-fasl-file-implementation 11) cmucl-21a/src/bootfiles/18c/boot10.lisp000066400000000000000000000051141260377556400177270ustar00rootroot00000000000000;; bootstrap changes in the way FASL-FILE-VERSION is checked ;; ;; Given that FASL files are incompatible between releases, the ;; FASL-FILE-NUMBER was set to #x18d on all platforms, so that users ;; loading old compiled lisp files into their core will see a useful ;; error message, rather than unexplained lossage. ;; ;; This check is made when loading a FASL file into core, in the ;; function FOP-CODE-FORMAT. We work around the check so that it is ;; possible to build from 18c, without requiring a cross-compile. ;; ;; Additionally, the FASL file format was changed slightly: We use the new ;; FOP-LONG-CODE-FORMAT with code 157, because the version number is now ;; an uint32 instead of a single octet. The old FOP-CODE-FORMAT with code ;; 57 is retained, in order to correctly read/detect old version numbers. (in-package :cl) ;; Declare new variable defined in code/load.lisp, so that new-genesis ;; can reference it, before code/load is loaded. (defvar *skip-fasl-file-version-check* nil) ;; Define nop FOP for the new FOP code of FOP-CODE-FORMAT (define-fop (fop-long-code-format 157 :nope) (let ((implementation (read-arg 1)) (version (read-arg 4))) (declare (ignore implementation version)) (warn "FOP-LONG-CODE-FORMAT ignoring FASL file versions during rebuild"))) (in-package :c) ;; this is a DEFCONSTANT, so can't use SETQ (setf (symbol-value 'byte-fasl-file-version) #x18d) (setf (backend-fasl-file-version *target-backend*) #x18d) ;; Use the new format for newly created FASLs (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/18c/boot2.lisp000066400000000000000000000113031260377556400176450ustar00rootroot00000000000000;;; -*- Package: C -*- (in-package :c) ;;; boot.lisp for proclaim/declaim fix. 3/3/2001 (setf (info function ir1-convert 'proclaim) nil) ;;; A version of this has to exist for the second build to work. (defun %declaim (what) (proclaim what)) (defmacro declaim (&rest specs) "DECLAIM Declaration* Do a declaration for the global environment." `(progn (eval-when (:load-toplevel :execute) ,@(mapcar #'(lambda (x) `(proclaim ',x)) specs)) (eval-when (:compile-toplevel) ,@(mapcar #'(lambda (x) `(%declaim ',x)) specs)))) (defun proclaim (form) (unless (consp form) (error "Malformed PROCLAIM spec: ~S." form)) (let ((kind (first form)) (args (rest form))) (case kind (special (dolist (name args) (unless (symbolp name) (error "Variable name is not a symbol: ~S." name)) (clear-info variable constant-value name) (setf (info variable kind name) :special))) (type (when *type-system-initialized* (let ((type (specifier-type (first args)))) (dolist (name (rest args)) (unless (symbolp name) (error "Variable name is not a symbol: ~S." name)) (setf (info variable type name) type) (setf (info variable where-from name) :declared))))) (ftype (when *type-system-initialized* (let ((type (specifier-type (first args)))) (unless (csubtypep type (specifier-type 'function)) (error "Declared functional type is not a function type: ~S." (first args))) (dolist (name (rest args)) (cond ((info function accessor-for name) (warn "Ignoring FTYPE declaration for slot accesor:~% ~S" name)) (t (define-function-name name) (note-name-defined name :function) (setf (info function type name) type) (setf (info function where-from name) :declared))))))) (freeze-type (dolist (type args) (let ((class (specifier-type type))) (when (typep class 'class) (setf (class-state class) :sealed) (let ((subclasses (class-subclasses class))) (when subclasses (do-hash (subclass layout subclasses) (declare (ignore layout)) (setf (class-state subclass) :sealed)))))))) (function ;; ;; Handle old-style FUNCTION declaration, which is a shorthand for ;; FTYPE. (when *type-system-initialized* (if (and (<= 2 (length args) 3) (listp (second args))) (proclaim `(ftype (function . ,(rest args)) ,(first args))) (proclaim `(type function . ,args))))) (optimize (setq *default-cookie* (process-optimize-declaration form *default-cookie*))) (optimize-interface (setq *default-interface-cookie* (process-optimize-declaration form *default-interface-cookie*))) ((inline notinline maybe-inline) (dolist (name args) (define-function-name name) (setf (info function inlinep name) (case kind (inline :inline) (notinline :notinline) (maybe-inline :maybe-inline))))) (constant-function (let ((info (make-function-info :attributes (ir1-attributes movable foldable flushable unsafe)))) (dolist (name args) (define-function-name name) (setf (info function info name) info)))) (declaration (dolist (decl args) (unless (symbolp decl) (error "Declaration to be RECOGNIZED is not a symbol: ~S." decl)) (setf (info declaration recognized decl) t))) ((start-block end-block)) ; ignore. (t (cond ((member kind type-specifier-symbols) (proclaim `(type . ,form))) ((or (info type kind kind) (and (consp kind) (info type translator (car kind)))) (proclaim `(type . ,form))) ((not (info declaration recognized kind)) (warn "Unrecognized proclamation: ~S." form)))))) (undefined-value)) (defmacro defvar (var &optional (val nil valp) (doc nil docp)) "For defining global variables at top level. Declares the variable SPECIAL and, optionally, initializes it. If the variable already has a value, the old value is not clobbered. The third argument is an optional documentation string for the variable." `(progn (declaim (special ,var)) ,@(when valp `((unless (boundp ',var) (setq ,var ,val)))) ,@(when docp `((setf (documentation ',var 'variable) ',doc))) ',var)) (defmacro defparameter (var val &optional (doc nil docp)) "Defines a parameter that is not normally changed by the program, but that may be changed without causing an error. Declares the variable special and sets its value to VAL. The third argument is an optional documentation string for the parameter." `(progn (declaim (special ,var)) (setq ,var ,val) ,@(when docp `((setf (documentation ',var 'variable) ',doc))) ',var)) cmucl-21a/src/bootfiles/18c/boot3.lisp000066400000000000000000000011641260377556400176520ustar00rootroot00000000000000;;; 3/13/01 Got rid of some symbols that didn't belong in CL package. ;;; Moved get-setf-method to extensions package since it is still used. ;;; Should be easy enough to flush later as it just calls ;;; get-setf-expansion checking for a single store value. ;;; ;;; Load this into compiler before attempting to worldcom/comcom. (unexport '(GET-SETF-METHOD-MULTIPLE-VALUE LOGICAL-PATHNAME-P DEFINE-SETF-METHOD HASH-TABLE-WEAK-P GET-SETF-METHOD) :lisp) ;;; Needed before load of exports.lisp to bootstrap ANSI defstruct fix (intern "*ANSI-DEFSTRUCT-OPTIONS-P*" :kernel) (load "target:code/exports.lisp") cmucl-21a/src/bootfiles/18c/boot4.lisp000066400000000000000000000006121260377556400176500ustar00rootroot00000000000000(in-package "VM") ;; Add some new constants for the Sparc backend. #+sparc (progn (defconstant fixnum-tag-bits (1- lowtag-bits) "Number of tag bits used for a fixnum") (defconstant fixnum-tag-mask (1- (ash 1 fixnum-tag-bits)) "Mask to get the fixnum tag") (defconstant positive-fixnum-bits (- word-bits fixnum-tag-bits 1) "Maximum number of bits in a positive fixnum") ) cmucl-21a/src/bootfiles/18c/boot5.lisp000066400000000000000000000067021260377556400176570ustar00rootroot00000000000000(in-package "C") (defun do-macro-compile-time (name def) (unless (symbolp name) (compiler-error "Macro name is not a symbol: ~S." name)) (ecase (info function kind name) ((nil)) (:function (remhash name *free-functions*) (undefine-function-name name) (compiler-warning "Defining ~S to be a macro when it was ~(~A~) to be a function." name (info function where-from name))) (:macro) (:special-form (compiler-error "Attempt to redefine special form ~S as a macro." name))) (setf (info function kind name) :macro) (setf (info function where-from name) :defined) (when *compile-time-define-macros* (setf (info function macro-function name) (coerce def 'function)))) (def-ir1-translator %defmacro ((name def lambda-list doc) start cont :kind :function) (let ((name (eval name)) (def (second def))) ; Don't want to make a function just yet... (let* ((*current-path* (revert-source-path 'defmacro)) (fun (ir1-convert-lambda def name 'defmacro))) (setf (leaf-name fun) (concatenate 'string "DEFMACRO " (symbol-name name))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) (when *compile-print* (compiler-mumble "Converted ~S.~%" name)))) (defun do-compiler-macro-compile-time (name def) (when (eq (info function kind name) :special-form) (compiler-error "Attempt to define a compiler-macro for special form ~S." name)) (when *compile-time-define-macros* (setf (info function compiler-macro-function name) (coerce def 'function)))) (def-ir1-translator %define-compiler-macro ((name def lambda-list doc) start cont :kind :function) (let ((name (eval name)) (def (second def))) ; Don't want to make a function just yet... (let* ((*current-path* (revert-source-path 'define-compiler-macro)) (fun (ir1-convert-lambda def name 'define-compiler-macro))) (setf (leaf-name fun) (let ((*print-case* :upcase)) (format nil "DEFINE-COMPILER-MACRO ~S" name))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) (when *compile-print* (compiler-mumble "Converted ~S.~%" name)))) (in-package "LISP") (defmacro defmacro (name lambda-list &body body) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro lambda-list whole body name 'defmacro :environment environment) (let ((def `(lambda (,whole ,environment) ,@local-decs (block ,name ,body)))) `(progn (eval-when (:compile-toplevel) (c::do-macro-compile-time ',name #',def)) (eval-when (:load-toplevel :execute) (c::%defmacro ',name #',def ',lambda-list ,doc))))))) (defmacro define-compiler-macro (name lambda-list &body body) "Define a compiler-macro for NAME." (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro lambda-list whole body name 'define-compiler-macro :environment environment) (let ((def `(lambda (,whole ,environment) ,@local-decs (block ,name ,body)))) `(progn (eval-when (:compile-toplevel) (c::do-compiler-macro-compile-time ',name #',def)) (eval-when (:load-toplevel :execute) (c::%define-compiler-macro ',name #',def ',lambda-list ,doc))))))) cmucl-21a/src/bootfiles/18c/boot6.lisp000066400000000000000000000003241260377556400176520ustar00rootroot00000000000000;; Bootstrap the pseudo-atomic trap genesis change to put ;; trap_PseudoAtomic into internals.h. #+sparc (load "target:code/exports.lisp") #+sparc (in-package :sparc) #+sparc (defconstant pseudo-atomic-trap 16) cmucl-21a/src/bootfiles/18c/boot7.lisp000066400000000000000000000003331260377556400176530ustar00rootroot00000000000000;; Add the constants for precision control on x86. ;; #+x86 (in-package :x86) #+x86 (progn (defconstant float-precision-24-bit 0) (defconstant float-precision-53-bit 2) (defconstant float-precision-64-bit 3)) cmucl-21a/src/bootfiles/18c/boot8.lisp000066400000000000000000000027171260377556400176640ustar00rootroot00000000000000(in-package "C") (defun do-defconstant-compile-time (name value doc) (unless (symbolp name) (compiler-error "Constant name is not a symbol: ~S." name)) (when (eq name t) (compiler-error "Can't change T.")) (when (eq name nil) (compiler-error "Nihil ex nihil (Can't change NIL).")) (when (keywordp name) (compiler-error "Can't change the value of keywords.")) (let ((kind (info variable kind name))) (case kind (:constant (unless (equalp value (info variable constant-value name)) (compiler-warning "Redefining constant ~S as:~% ~S" name value))) (:global) (t (compiler-warning "Redefining ~(~A~) ~S to be a constant." kind name)))) (setf (info variable kind name) :constant) (setf (info variable where-from name) :defined) (setf (info variable constant-value name) value) (remhash name *free-variables*)) (in-package "LISP") ;;; DEFCONSTANT -- Public ;;; (defmacro defconstant (var val &optional doc) "For defining global constants at top level. The DEFCONSTANT says that the value is constant and may be compiled into code. If the variable already has a value, and this is not equal to the init, an error is signalled. The third argument is an optional documentation string for the variable." `(progn (eval-when (:compile-toplevel) (c::do-defconstant-compile-time ',var ,val ',doc)) (eval-when (:load-toplevel :execute) (c::%%defconstant ',var ,val ',doc)))) cmucl-21a/src/bootfiles/18c/boot9.lisp000066400000000000000000000002771260377556400176640ustar00rootroot00000000000000#+x86 (in-package :x86) #+x86 (progn (defparameter target-static-space-start #+FreeBSD #x28F00000 #-FreeBSD #x28000000) (defparameter nil-value (+ target-static-space-start #xB))) cmucl-21a/src/bootfiles/18d/000077500000000000000000000000001260377556400157325ustar00rootroot00000000000000cmucl-21a/src/bootfiles/18d/boot-mips.lisp000066400000000000000000000205541260377556400205420ustar00rootroot00000000000000 (in-package "EXTENSIONS") (export '(with-float-traps-masked)) (in-package "VM") ;;; WITH-FLOAT-TRAPS-MASKED -- Public ;;; (defmacro with-float-traps-masked (traps &body body) "Execute BODY with the floating point exceptions listed in TRAPS masked (disabled). TRAPS should be a list of possible exceptions which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective accrued exceptions are cleared at the start of the body to support their testing within, and restored on exit." (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0)) (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0)) (trap-mask (dpb (lognot (float-trap-mask traps)) float-traps-byte #xffffffff)) (exception-mask (dpb (lognot (vm::float-trap-mask traps)) float-sticky-bits #xffffffff)) (orig-modes (gensym))) `(let ((,orig-modes (floating-point-modes))) (unwind-protect (progn (setf (floating-point-modes) (logand ,orig-modes ,(logand trap-mask exception-mask))) ,@body) ;; Restore the original traps and exceptions. (setf (floating-point-modes) (logior (logand ,orig-modes ,(logior traps exceptions)) (logand (floating-point-modes) ,(logand trap-mask exception-mask) ,(dpb 0 float-exceptions-byte #xffffffff)))) )))) (in-package "C") ;;; Apply the function F to a bound X. If X is an open bound, then the result ;;; will be open. IF X is NIL, the result is NIL. ;;; (defun bound-func (f x) (and x (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) ;; With these traps masked, we might get things like infinity or ;; negative infinity returned. Check for this and return NIL to ;; indicate unbounded. (let ((y (funcall f (bound-value x)))) (if (and (floatp y) (float-infinity-p y)) nil (set-bound (funcall f (bound-value x)) (consp x))))))) ;;; Apply a binary operator OP to two bounds X and Y. The result is NIL if ;;; either is NIL. Otherwise bound is computed and the result is open if ;;; either X or Y is open. ;;; (defmacro bound-binop (op x y) `(and ,x ,y (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) (set-bound (,op (bound-value ,x) (bound-value ,y)) (or (consp ,x) (consp ,y)))))) ;;; ONE-ARG-DERIVE-TYPE ;;; ;;; This is used in defoptimizers for computing the resulting type of a ;;; function. ;;; ;;; Given the continuation ARG, derive the resulting type using the ;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some "atomic" ;;; continuation type like numeric-type or member-type (containing just one ;;; element). It should return the resulting type, which can be a list of ;;; types. ;;; ;;; For the case of member types, if a member-fcn is given it is called to ;;; compute the result otherwise the member type is first converted to a ;;; numeric type and the derive-fcn is call. ;;; (defun one-arg-derive-type (arg derive-fcn member-fcn &optional (convert-type t)) (declare (type function derive-fcn) (type (or null function) member-fcn) #+negative-zero-is-not-zero (ignore convert-type)) (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (when arg-list (flet ((deriver (x) (typecase x (member-type (if member-fcn (with-float-traps-masked (:underflow :overflow :divide-by-zero) (make-member-type :members (list (funcall member-fcn (first (member-type-members x)))))) ;; Otherwise convert to a numeric type. (let ((result-type-list (funcall derive-fcn (convert-member-type x)))) #-negative-zero-is-not-zero (if convert-type (convert-back-numeric-type-list result-type-list) result-type-list) #+negative-zero-is-not-zero result-type-list))) (numeric-type #-negative-zero-is-not-zero (if convert-type (convert-back-numeric-type-list (funcall derive-fcn (convert-numeric-type x))) (funcall derive-fcn x)) #+negative-zero-is-not-zero (funcall derive-fcn x)) (t *universal-type*)))) ;; Run down the list of args and derive the type of each one, saving ;; all of the results in a list. (let ((results nil)) (dolist (arg arg-list) (let ((result (deriver arg))) (if (listp result) (setf results (append results result)) (push result results)))) (if (rest results) (make-canonical-union-type results) (first results))))))) ;;; TWO-ARG-DERIVE-TYPE ;;; ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes two ;;; arguments. DERIVE-FCN takes 3 args in this case: the two original args ;;; and a third which is T to indicate if the two args really represent the ;;; same continuation. This is useful for deriving the type of things like ;;; (* x x), which should always be positive. If we didn't do this, we ;;; wouldn't be able to tell. ;;; ;;; Without the negative-zero-is-not-zero feature, numeric types are first ;;; converted to the negative-zero-is-not-zero conventions as expected by the ;;; deriver function. ;;; ;;; For the case of two member types, the result may be derived by calling the ;;; given function FCN but if a NaN is generated then an unbounded type is ;;; returned. Alternatively a tighter, less conservative, type can often be ;;; returned by converting to numeric types and calling the deriver function, ;;; which is the default behavior without the conservative-float-type feature. ;;; (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn &optional (convert-type t)) #+negative-zero-is-not-zero (declare (ignore convert-type)) #-conservative-float-type (declare (ignore fcn)) (labels ((maybe-convert-numeric-type (type) #-negative-zero-is-not-zero (if convert-type (convert-numeric-type type) type) #+negative-zero-is-not-zero type) (maybe-convert-back-type-list (type) #-negative-zero-is-not-zero (if convert-type (convert-back-numeric-type-list type) type) #+negative-zero-is-not-zero type) (deriver (x y same-arg) (cond #+conservative-float-type ((and (member-type-p x) (member-type-p y)) (let* ((x (first (member-type-members x))) (y (first (member-type-members y))) (result (with-float-traps-masked (:underflow :overflow :divide-by-zero :invalid) (funcall fcn x y)))) (cond ((null result)) ((and (floatp result) (float-nan-p result)) (make-numeric-type :class 'float :format (type-of result) :complexp :real)) (t (make-member-type :members (list result)))))) #-conservative-float-type ((and (member-type-p x) (member-type-p y)) (let* ((x (convert-member-type x)) (y (convert-member-type y)) (result (funcall derive-fcn x y same-arg))) (maybe-convert-back-type-list result))) ((and (member-type-p x) (numeric-type-p y)) (let* ((x (convert-member-type x)) (y (maybe-convert-numeric-type y)) (result (funcall derive-fcn x y same-arg))) (maybe-convert-back-type-list result))) ((and (numeric-type-p x) (member-type-p y)) (let* ((x (maybe-convert-numeric-type x)) (y (convert-member-type y)) (result (funcall derive-fcn x y same-arg))) (maybe-convert-back-type-list result))) ((and (numeric-type-p x) (numeric-type-p y)) (let* ((x (maybe-convert-numeric-type x)) (y (maybe-convert-numeric-type y)) (result (funcall derive-fcn x y same-arg))) (maybe-convert-back-type-list result))) (t *universal-type*)))) (let ((same-arg (same-leaf-ref-p arg1 arg2)) (a1 (prepare-arg-for-derive-type (continuation-type arg1))) (a2 (prepare-arg-for-derive-type (continuation-type arg2)))) (when (and a1 a2) (let ((results nil)) (if same-arg ;; Since the args are the same continuation, just run ;; down the lists. (dolist (x a1) (let ((result (deriver x x same-arg))) (if (listp result) (setf results (append results result)) (push result results)))) ;; Try all pairwise combinations. (dolist (x a1) (dolist (y a2) (let ((result (or (deriver x y same-arg) (numeric-contagion x y)))) (if (listp result) (setf results (append results result)) (push result results)))))) (if (rest results) (make-canonical-union-type results) (first results))))))) cmucl-21a/src/bootfiles/18d/boot1.lisp000066400000000000000000000032441260377556400176520ustar00rootroot00000000000000;;; This file bootstraps the changes in extern-alien-name, which ;;; brings the x86 handling of underscores on non-ELF systems in ;;; line with other ports, by moving the underscore addition to ;;; extern-alien-name, where it belongs, and not f-s-a-aux. ;;; This also makes foreign linking work better on OpenBSD. ;;; #+x86 (in-package "LISP") #+x86 (defun foreign-symbol-address-aux (symbol) (multiple-value-bind (value found) (gethash symbol *foreign-symbols* 0) ;; can't make irix linker give values in the symbol table to global vars ;;from dsos, so we have to resolve at runtime (and handle symbols being ;;defined with null values) (if #-irix found #+irix (and found (not (zerop value))) value (let ((value (system:alternate-get-global-address symbol))) (when (zerop value) (error "Unknown foreign symbol: ~S" symbol)) value)))) #+x86 (in-package "X86") #+x86 (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) #+(and x86 (or linux (and freebsd elf))) (defun lisp::foreign-symbol-address-aux (name) (multiple-value-bind (value found) (gethash name lisp::*foreign-symbols* 0) (if found value (multiple-value-bind (value found) (gethash (concatenate 'string "PVE_stub_" name) lisp::*foreign-symbols* 0) (if found value (let ((value (system:alternate-get-global-address name))) (when (zerop value) (error "Unknown foreign symbol: ~S" name)) value)))))) cmucl-21a/src/bootfiles/18d/boot10.lisp000066400000000000000000000020031260377556400177220ustar00rootroot00000000000000;;;; ;;;; Boot file for the new/changed static symbols LISP::*CMUCL-LIB* ;;;; and LISP::*CMUCL-CORE-PATH* (CMUCL_LIB and CMUCL_CORE_PATH in ;;;; the C runtime). ;;;; ;;; ;;; This is the same function as in tools/setup.lisp. It is here ;;; because setup.lisp is loaded after bootstrap.lisp in pmai's ;;; build scripts. ;;; (defun vmdir (f) (merge-pathnames (make-pathname :directory nil :defaults f) (merge-pathnames (cond ((c:target-featurep :pmax) "mips/") ((c:target-featurep :rt) "rt/") ((c:target-featurep :hppa) "hppa/") ((c:target-featurep :sparc) "sparc/") ((c:target-featurep :x86) "x86/") ((c:target-featurep :alpha) "alpha/") ((c:target-featurep :sgi) "mips/") ((c:target-featurep :ppc) "ppc/") (t (error "What machine is this?"))) (make-pathname :directory (pathname-directory f))))) ;;; ;;; Load parms.lisp into the compiling Lisp so that it writes the new ;;; symbols to internals.h during genesis. ;;; (load (vmdir "target:compiler/parms")) ;;;; end of boot10.lisp cmucl-21a/src/bootfiles/18d/boot11-alpha-linux.lisp000066400000000000000000000004541260377556400221530ustar00rootroot00000000000000; This file is only needed when compiling for the Alpha under Linux, to add the ; new Alpha-only ISTREAM-MEMORY-BARRIER VOP. (in-package "ALPHA") (define-instruction imb (segment) (:emitter (emit-pal segment 0 #x000086))) (define-vop (c::istream-memory-barrier) (:generator 1 (inst imb))) cmucl-21a/src/bootfiles/18d/boot2.lisp000066400000000000000000000011171260377556400176500ustar00rootroot00000000000000#+sparc (in-package "SPARC") #+sparc (defmacro allocation (result-tn size lowtag) ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is ;; set. If the lowtag also has a 1 bit in the same position, we're all ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and ;; then or in the lowtag. `(if (logbitp (1- lowtag-bits) ,lowtag) (progn (inst or ,result-tn alloc-tn ,lowtag) (inst add alloc-tn ,size)) (progn (inst andn ,result-tn alloc-tn lowtag-mask) (inst or ,result-tn ,lowtag) (inst add alloc-tn ,size)))) cmucl-21a/src/bootfiles/18d/boot3.lisp000066400000000000000000000005731260377556400176560ustar00rootroot00000000000000;; Unexport the newly re-introduced compiler-macroexpand* symbols from ;; the CL package. This is for the benefit of old cores, which might ;; still have those "exported", even though the functions (or even the ;; symbols) don't exist. This is deep CMUCL voodoo magic, don't even ;; try to understand it. (unexport '(CL::COMPILER-MACROEXPAND-1 CL::COMPILER-MACROEXPAND) "CL") cmucl-21a/src/bootfiles/18d/boot4-cross-foreign-linkage-sparc.lisp000066400000000000000000000221571260377556400251550ustar00rootroot00000000000000(in-package "USER") ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") ;;; Sparc to Sparc current cross compile. ;#+nil (c::new-backend "SPARC" '(:new-assembler :complex-fp-vops :sparc-v9 :hash-new :random-mt19937 :cmu18 :cmu18d :sparc :relative-package-names :linkage-table) '(:gencgc :x86 :x86-bootstrap :alpha :osf1 :mips :pentium :cgc :mp :i486 :long-float :new-random) ) #| (load "target:tools/setup" :if-source-newer :load-source) (comf "target:tools/setup" :load t) |# (setf *interactive* nil) (setf *gc-verbose* nil) ;;; Extern-alien-name for the new backend. (in-package "VM") (defun extern-alien-name (name) (declare (type simple-string name)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package "USER") ;;; So compilation of make-fixup will work. (setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") (comf "target:code/foreign-linkage") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;;; Note: may need to add extra files to load to loadbackend, perhaps ;;; float-tran and srctran; try to follow the order in comcom as this ;;; is often important. ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "target:code/foreign-linkage") (load "target:compiler/dump") (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET OLD-SPARC:CERROR-TRAP OLD-SPARC:ERROR-TRAP OLD-SPARC::LOWTAG-BITS OLD-SPARC:CATCH-BLOCK-SIZE )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Ready to build. (pushnew :bootstrap *features*) #+nil (let* ((old-package :old-sparc) (sym (find-symbol "ANY-REG" old-package))) (unintern sym (symbol-package sym)) ;;(import sym :sparc) (import sym old-package) ) ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg to ;; the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) (in-package "ALIEN") (defun %def-alien-variable (lisp-name alien-name type) (setf (info variable kind lisp-name) :alien) (setf (info variable where-from lisp-name) :defined) (clear-info variable constant-value lisp-name) (setf (info variable alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-address ',alien-name :flavor :data)))) (defmacro extern-alien (name type) "Access the alien variable named NAME, assuming it is of type TYPE. This is setfable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) `(%heap-alien ',(make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',alien-name :flavor ',flavor))))) (defmacro with-alien (bindings &body body) "Establish some local alien variables. Each BINDING is of the form: VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. :STATIC The alien is allocated on the heap, and has infinate extent. The alien is allocated at load time, so the same piece of memory is used each time this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." (with-auxiliary-alien-types (dolist (binding (reverse bindings)) (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (let* ((alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) (case opt1 (:extern (values opt1 (guess-alien-name-from-lisp-name symbol))) (:static (values opt1 nil)) (t (values :local opt1)))) (setf body (ecase allocation #+nil (:static (let ((sap (make-symbol (concatenate 'string "SAP-FOR-" (symbol-name symbol))))) `((let ((,sap (load-time-value (%make-alien ...)))) (declare (type system-area-pointer ,sap)) (symbol-macrolet ((,symbol (sap-alien ,sap ,type))) ,@(when initial-value `((setq ,symbol ,initial-value))) ,@body))))) (:extern (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',initial-value :flavor ',flavor)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) (note-local-alien-type ',info ,var) (multiple-value-prog1 (symbol-macrolet ((,symbol (local-alien ',info ,var))) ,@(when initial-value `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var) ))))))))))) (verify-local-auxiliaries-okay) `(compiler-let ((*auxiliary-type-definitions* ',(append *new-auxiliary-types* *auxiliary-type-definitions*))) ,@body))) (defparameter cl-user::*load-stuff* nil) #| (load "target:tools/worldcom") (load "target:tools/comcom") ;;; If worldbuild produces a warning that "The C header file has ;;; changed." then it will be necessary to recompile the C code, and ;;; run worldload again. (load "target:tools/worldbuild") (quit) |# cmucl-21a/src/bootfiles/18d/boot4-cross-foreign-linkage.lisp000066400000000000000000000211541260377556400240430ustar00rootroot00000000000000;;; This script builds a cross compiler that can then build a new ;;; system with the linkage table changes. It works well with Pierre ;;; Mai's build scripts. (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86") (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here '(:x86 :i486 :mp :gencgc :conservative-float-type :hash-new :random-mt19937 :cmu :cmu18 :cmu18d ;; :freebsd :freebsd4 :elf :linkage-table :relative-package-names ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :pentium ;; :glibc2 :linux :freebsd :long-float :new-random :small)) ;;; So compilation of make-fixup will work. (setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") (comf "target:code/foreign-linkage") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "target:code/foreign-linkage") (load "target:compiler/dump") (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-BIT-VECTOR-TYPE OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'x86::any-reg ht))) (in-package "ALIEN") (defun %def-alien-variable (lisp-name alien-name type) (setf (info variable kind lisp-name) :alien) (setf (info variable where-from lisp-name) :defined) (clear-info variable constant-value lisp-name) (setf (info variable alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-address ',alien-name :flavor :data)))) (defmacro extern-alien (name type) "Access the alien variable named NAME, assuming it is of type TYPE. This is setfable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) `(%heap-alien ',(make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',alien-name :flavor ',flavor))))) (defmacro with-alien (bindings &body body) "Establish some local alien variables. Each BINDING is of the form: VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. :STATIC The alien is allocated on the heap, and has infinate extent. The alien is allocated at load time, so the same piece of memory is used each time this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." (with-auxiliary-alien-types (dolist (binding (reverse bindings)) (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (let* ((alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) (case opt1 (:extern (values opt1 (guess-alien-name-from-lisp-name symbol))) (:static (values opt1 nil)) (t (values :local opt1)))) (setf body (ecase allocation #+nil (:static (let ((sap (make-symbol (concatenate 'string "SAP-FOR-" (symbol-name symbol))))) `((let ((,sap (load-time-value (%make-alien ...)))) (declare (type system-area-pointer ,sap)) (symbol-macrolet ((,symbol (sap-alien ,sap ,type))) ,@(when initial-value `((setq ,symbol ,initial-value))) ,@body))))) (:extern (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',initial-value :flavor ',flavor)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) (note-local-alien-type ',info ,var) (multiple-value-prog1 (symbol-macrolet ((,symbol (local-alien ',info ,var))) ,@(when initial-value `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var) ))))))))))) (verify-local-auxiliaries-okay) `(compiler-let ((*auxiliary-type-definitions* ',(append *new-auxiliary-types* *auxiliary-type-definitions*))) ,@body))) cmucl-21a/src/bootfiles/18d/boot5.lisp000066400000000000000000000037611260377556400176620ustar00rootroot00000000000000;;; Add a new superclass, required by the ANSI Spec, to fd-stream ;;; without causing a blowup in genesis. (in-package "LISP") (defstruct (file-stream (:include lisp-stream) (:constructor nil) (:copier nil))) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (fd-stream (:print-function %print-fd-stream) (:constructor %make-fd-stream) (:include file-stream (misc #'fd-stream-misc-routine))) (name nil) ; The name of this stream (file nil) ; The file this stream is for ;; ;; The backup file namestring for the old file, for :if-exists :rename or ;; :rename-and-delete. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete ;; ;; Number of bytes per element. (element-size 1 :type index) (element-type 'base-char) ; The type of element being transfered. (fd -1 :type fixnum) ; The file descriptor ;; ;; Controls when the output buffer is flushed. (buffering :full :type (member :full :line :none)) ;; ;; Character position if known. (char-pos nil :type (or index null)) ;; ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) ;; ;; The input buffer. (unread nil) (ibuf-sap nil :type (or system-area-pointer null)) (ibuf-length nil :type (or index null)) (ibuf-head 0 :type index) (ibuf-tail 0 :type index) ;; The output buffer. (obuf-sap nil :type (or system-area-pointer null)) (obuf-length nil :type (or index null)) (obuf-tail 0 :type index) ;; Output flushed, but not written due to non-blocking io. (output-later nil) (handler nil) ;; ;; Timeout specified for this stream, or NIL if none. (timeout nil :type (or index null)) ;; ;; Pathname of the file this stream is opened to (returned by PATHNAME.) (pathname nil :type (or pathname null)))) cmucl-21a/src/bootfiles/18d/boot6-a.lisp000066400000000000000000000065061260377556400201010ustar00rootroot00000000000000;; For bootstrapping the conc-name inheritance fix, part 1. ;; ;; You need to do a build loading just this file but NOT boot6-b.lisp. ;; The next build MUST NOT use this file and load up boot6-b ;; instead. ;; ;; Use the CLOBBER-IT restart when prompted for a restart. (pushnew :bootstrap-conc-name *features*) (in-package "KERNEL") (defstruct (defstruct-description (:conc-name dd-) (:print-function print-defstruct-description) (:make-load-form-fun :just-dump-it-normally) (:pure t) (:constructor make-defstruct-description (name))) ;; ;; name of the structure (name (required-argument) :type symbol) ;; ;; documentation on the structure (doc nil :type (or string null)) ;; ;; prefix for slot names. If NIL, none. (conc-name (concat-pnames name '-) :type (or symbol null)) ;; ;; The name of the primary standard keyword constructor, or NIL if none. (default-constructor nil :type (or symbol null)) ;; ;; All the explicit :CONSTRUCTOR specs, with name defaulted. (constructors () :type list) ;; ;; name of copying function (copier (concat-pnames 'copy- name) :type (or symbol null)) ;; ;; Name of type predictate (predicate (concat-pnames name '-p) :type (or symbol null)) ;; ;; The arguments to the :INCLUDE option, or NIL if no included structure. (include nil :type list) ;; ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to ;; define structure-like objects with an arbitrary superclass and that may ;; not have STRUCTURE-CLASS as the metaclass.) Syntax is: ;; (superclass-name metaclass-name metaclass-constructor) ;; (alternate-metaclass nil :type list) ;; ;; list of defstruct-slot-description objects for all slots (including ;; included ones.) (slots () :type list) ;; ;; Number of elements we've allocated (see also raw-length.) (length 0 :type index) ;; ;; General kind of implementation. (type 'structure :type (member structure vector list funcallable-structure)) ;; ;; The next three slots are for :TYPE'd structures (which aren't classes, ;; CLASS-STRUCTURE-P = NIL) ;; ;; Vector element type. (element-type 't) ;; ;; T if :NAMED was explicitly specified, Nil otherwise. (named nil :type boolean) ;; ;; Any INITIAL-OFFSET option on this direct type. (offset nil :type (or index null)) ;; ;; The argument to the PRINT-FUNCTION option, or NIL if none. If we see an ;; explicit (:PRINT-FUNCTION) option, then this is DEFAULT-STRUCTURE-PRINT. ;; See also BASIC-STRUCTURE-CLASS-PRINTER. Only for classed structures. ;; (print-function nil :type (or cons symbol null)) ;; ;; The next four slots are only meaningful in real default structures (TYPE = ;; STRUCTURE). ;; ;; Make-load-form function option. See also STRUCTURE-CLASS-LOAD-FORM-MAKER. (make-load-form-fun nil :type (or symbol cons null)) ;; ;; The index of the raw data vector and the number of words in it. NIL and 0 ;; if not allocated yet. (raw-index nil :type (or index null)) (raw-length 0 :type index) ;; ;; Value of the :PURE option, or :UNSPECIFIED. Only meaningful if ;; CLASS-STRUCTURE-P = T. (pure :unspecified :type (member t nil :substructure :unspecified)) ;; ;; a list of (NAME . INDEX) pairs for accessors of included structures (inherited-accessor-alist () :type list)) cmucl-21a/src/bootfiles/18d/boot6-b.lisp000066400000000000000000000175271260377556400201070ustar00rootroot00000000000000;; For bootstrapping the conc-name inheritance fix, part 2. ;; ;; This file should be loaded up from a lisp.core that was built using ;; boot6-a.lisp. Load ONLY boot6-b (and NOT boot6-a) when building ;; with this. (setf *features* (remove :bootstrap-conc-name *features*)) (in-package "KERNEL") (defun accessor-inherited-data (name defstruct) (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq)) (defun do-inclusion-stuff (defstruct) (destructuring-bind (included-name &rest modified-slots) (dd-include defstruct) (let* ((type (dd-type defstruct)) (included-structure (if (class-structure-p defstruct) (layout-info (compiler-layout-or-lose included-name)) (typed-structure-info-or-lose included-name)))) (unless (and (eq type (dd-type included-structure)) (type= (specifier-type (dd-element-type included-structure)) (specifier-type (dd-element-type defstruct)))) (error ":TYPE option mismatch between structures ~S and ~S." (dd-name defstruct) included-name)) (incf (dd-length defstruct) (dd-length included-structure)) (when (class-structure-p defstruct) (unless (dd-print-function defstruct) (setf (dd-print-function defstruct) (dd-print-function included-structure))) (unless (dd-make-load-form-fun defstruct) (setf (dd-make-load-form-fun defstruct) (dd-make-load-form-fun included-structure))) (let ((mc (rest (dd-alternate-metaclass included-structure)))) (when (and mc (not (dd-alternate-metaclass defstruct))) (setf (dd-alternate-metaclass defstruct) (cons included-name mc)))) (when (eq (dd-pure defstruct) :unspecified) (setf (dd-pure defstruct) (dd-pure included-structure))) (setf (dd-raw-index defstruct) (dd-raw-index included-structure)) (setf (dd-raw-length defstruct) (dd-raw-length included-structure))) (setf (dd-inherited-accessor-alist defstruct) (dd-inherited-accessor-alist included-structure)) (dolist (islot (dd-slots included-structure)) (let* ((iname (dsd-name islot)) (modified (or (find iname modified-slots :key #'(lambda (x) (if (atom x) x (car x))) :test #'string=) `(,iname)))) ;; ;; We stash away an alist of accessors to parents' slots ;; that have already been created to avoid conflicts later ;; so that structures with :INCLUDE and :CONC-NAME (and ;; other edge cases) can work as specified. (when (dsd-accessor islot) ;; the "oldest" (i.e. highest up the tree of inheritance) ;; will prevail, so don't push new ones on if they ;; conflict. (pushnew (cons (dsd-accessor islot) (dsd-index islot)) (dd-inherited-accessor-alist defstruct) :test #'eq :key #'car)) (parse-1-dsd defstruct modified (copy-defstruct-slot-description islot))))))) (defun define-accessors (defstruct) (collect ((stuff)) (let ((ltype (dd-lisp-type defstruct))) (dolist (slot (dd-slots defstruct)) (let* ((aname (dsd-accessor slot)) (index (dsd-index slot)) (slot-type `(and ,(dsd-type slot) ,(dd-element-type defstruct))) (inherited (accessor-inherited-data aname defstruct))) (cond ((not inherited) (stuff `(declaim (inline ,aname (setf ,aname)))) (stuff `(defun ,aname (structure) (declare (type ,ltype structure)) (the ,slot-type (elt structure ,index)))) (unless (dsd-read-only slot) (stuff `(defun (setf ,aname) (new-value structure) (declare (type ,ltype structure) (type ,slot-type new-value)) (setf (elt structure ,index) new-value))))) ((not (= (cdr inherited) index)) (warn 'simple-style-warning :format-control "~@" :format-arguments (list aname (dsd-%name slot)))))))) (stuff))) (defun undefine-structure (class) (let ((info (layout-info (class-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (setf (info type compiler-layout type) nil) (undefine-function-name (dd-copier info)) (undefine-function-name (dd-predicate info)) (dolist (slot (dd-slots info)) (unless (dsd-inherited-p info slot) (let ((aname (dsd-accessor slot))) (unless (accessor-inherited-data aname info) (undefine-function-name aname) (unless (dsd-read-only slot) (undefine-function-name `(setf ,aname)))))))) ;; ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are ;; unknown types. (values-specifier-type-cache-clear))) (undefined-value)) (defun %%compiler-defstruct (info) (declare (type defstruct-description info)) (let* ((name (dd-name info)) (class (find-class name))) (let ((copier (dd-copier info))) (when copier (proclaim `(ftype (function (,name) ,name) ,copier)))) (let ((pred (dd-predicate info))) (when pred (define-defstruct-name pred) (setf (info function inlinep pred) :inline) (setf (info function inline-expansion pred) `(lambda (x) (typep x ',name))))) (dolist (slot (dd-slots info)) (let* ((aname (dsd-accessor slot)) (setf-fun `(setf ,aname)) (inherited (and aname (accessor-inherited-data aname info)))) (cond (inherited (unless (= (cdr inherited) (dsd-index slot)) (warn 'simple-style-warning :format-control "~@" :format-arguments (list aname (dsd-%name slot))))) (t (unless (or (dsd-inherited-p info slot) (not (eq (dsd-raw-type slot) 't))) (define-defstruct-name aname) (setf (info function accessor-for aname) class) (unless (dsd-read-only slot) (define-defstruct-name setf-fun) (setf (info function accessor-for setf-fun) class)))))))) (undefined-value)) (defun %defstruct (info inherits) (declare (type defstruct-description info)) (multiple-value-bind (class layout old-layout) (ensure-structure-class info inherits "current" "new") (cond ((not old-layout) (unless (eq (class-layout class) layout) (register-layout layout))) (t (let ((old-info (layout-info old-layout))) (when (defstruct-description-p old-info) (dolist (slot (dd-slots old-info)) (unless (dsd-inherited-p old-info slot) (let ((aname (dsd-accessor slot))) (fmakunbound aname) (unless (dsd-read-only slot) (fmakunbound `(setf ,aname)))))))) (%redefine-defstruct class old-layout layout) (setq layout (class-layout class)))) (setf (find-class (dd-name info)) class) (unless (eq (dd-type info) 'funcallable-structure) (dolist (slot (dd-slots info)) (unless (or (dsd-inherited-p info slot) (not (eq (dsd-raw-type slot) 't))) (let* ((aname (dsd-accessor slot)) (inherited (accessor-inherited-data aname info))) (unless inherited (setf (symbol-function aname) (structure-slot-accessor layout slot)) (unless (dsd-read-only slot) (setf (fdefinition `(setf ,aname)) (structure-slot-setter layout slot))))))) (when (dd-predicate info) (setf (symbol-function (dd-predicate info)) #'(lambda (object) (declare (optimize (speed 3) (safety 0))) (typep-to-layout object layout)))) (when (dd-copier info) (setf (symbol-function (dd-copier info)) #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (unless (typep-to-layout structure layout) (error 'simple-type-error :datum structure :expected-type class :format-control "Structure for copier is not a ~S:~% ~S" :format-arguments (list class structure))) (copy-structure structure)))))) (when (dd-doc info) (setf (documentation (dd-name info) 'type) (dd-doc info))) (undefined-value)) cmucl-21a/src/bootfiles/18d/boot7-sparc-cross-static-syms.lisp000066400000000000000000000142631260377556400243760ustar00rootroot00000000000000;;; Cross-compile script for adding some new static symbols for the ;;; core search routines. ;;; ;;; Intended only for the sparc port. Works with Pierre Mai's build ;;; scripts. ;;; ;;; You may get an error on loading target:compiler/new-assem. Use ;;; the CONTINUE restart (return NIL from load). The build should ;;; continue successfully. You should take the resulting build and ;;; recompile everything once again to be sure. ;;; ;;; I (RLT) don't know why this message is there and why it's not a ;;; real problem, but the resulting cross-compiled result should work, ;;; and does work for me. ;;; (in-package "USER") ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") ;;; Sparc to Sparc current cross compile. ;#+nil (c::new-backend "SPARC" '(:new-assembler :complex-fp-vops :sparc-v9 :hash-new :random-mt19937 :cmu18 :cmu18d :sparc :relative-package-names :linkage-table) '(:gencgc :x86 :x86-bootstrap :alpha :osf1 :mips :pentium :cgc :mp :i486 :long-float :new-random) ) #| (load "target:tools/setup" :if-source-newer :load-source) (comf "target:tools/setup" :load t) |# (setf *interactive* nil) (setf *gc-verbose* nil) ;;; Extern-alien-name for the new backend. (in-package "VM") (defun extern-alien-name (name) (declare (type simple-string name)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package "USER") ;;; So compilation of make-fixup will work. (setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150) ;;; Compile the new backend. (pushnew :bootstrap *features*) (load "target:tools/comcom") ;;(comf "target:code/foreign-linkage") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;;; Note: may need to add extra files to load to loadbackend, perhaps ;;; float-tran and srctran; try to follow the order in comcom as this ;;; is often important. ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) ;;(load "target:code/foreign-linkage") ;;(load "target:compiler/dump") (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. ;;(setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET OLD-SPARC:CERROR-TRAP OLD-SPARC:ERROR-TRAP OLD-SPARC::LOWTAG-BITS OLD-SPARC:CATCH-BLOCK-SIZE )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Ready to build. (pushnew :bootstrap *features*) #+nil (let* ((old-package :old-sparc) (sym (find-symbol "ANY-REG" old-package))) (unintern sym (symbol-package sym)) ;;(import sym :sparc) (import sym old-package) ) ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg to ;; the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) #| (load "target:tools/worldcom") (load "target:tools/comcom") ;;; If worldbuild produces a warning that "The C header file has ;;; changed." then it will be necessary to recompile the C code, and ;;; run worldload again. (load "target:tools/worldbuild") (quit) |# cmucl-21a/src/bootfiles/18d/boot8.lisp000066400000000000000000000033521260377556400176610ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 18e. ;;;; (in-package :c) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; (setf (symbol-value 'byte-fasl-file-version) #x18e) (setf (backend-fasl-file-version *target-backend*) #x18e) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq cl::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) ;;;; end of boot8.lisp cmucl-21a/src/bootfiles/18d/boot9.lisp000066400000000000000000000034241260377556400176620ustar00rootroot00000000000000(in-package "EXTENSIONS") (export '(define-function-name-syntax valid-function-name-p)) (in-package "LISP") ;;;; Function names. (defvar *valid-function-names* ()) (defun %define-function-name-syntax (name syntax-checker) (let ((found (assoc name *valid-function-names* :test #'eq))) (if found (setf (cdr found) syntax-checker) (setq *valid-function-names* (acons name syntax-checker *valid-function-names*))))) (defmacro define-function-name-syntax (name (var) &body body) "Define (NAME ...) to be a valid function name whose syntax is checked by BODY. In BODY, VAR is bound to an actual function name of the form (NAME ...) to check. BODY should return two values. First value true means the function name is valid. Second value is the name, a symbol, of the function for use in the BLOCK of DEFUNs and in similar situations." (let ((syntax-checker (symbolicate '%check- name '-function-name))) `(progn (defun ,syntax-checker (,var) ,@body) (%define-function-name-syntax ',name #',syntax-checker)))) (defun valid-function-name-p (name) "First value is true if NAME has valid function name syntax. Second value is the name, a symbol, to use as a block name in DEFUNs and in similar situations." (typecase name (cons (when (and (symbolp (car name)) (consp (cdr name))) (let ((syntax-checker (cdr (assoc (car name) *valid-function-names* :test #'eq)))) (when syntax-checker (funcall syntax-checker name))))) (symbol (values t name)) (otherwise nil))) (define-function-name-syntax setf (name) (destructuring-bind (setf fn &rest rest) name (declare (ignore setf)) (when (null rest) (typecase fn (symbol (values t fn)) (cons (unless (eq 'setf (car fn)) (valid-function-name-p fn))))))) cmucl-21a/src/bootfiles/18e/000077500000000000000000000000001260377556400157335ustar00rootroot00000000000000cmucl-21a/src/bootfiles/18e/boot1.lisp000066400000000000000000000122731260377556400176550ustar00rootroot00000000000000;;; ;;; Bootstrap file 1 of 2 for moving LISP:CLASS and assorted functions ;;; and types to KERNEL, so that they are freed for use by PCL. ;;; ;;; Use this file as bootstrap.lisp, using Pierre Mai's build scripts, ;;; to cross-compile, resulting in a Lisp that is almost what we ;;; need to get to final result, except that it has still CLASS-NAME ;;; defined as a function, which needs to be corrected in a second ;;; build with the second bootstrap file of this series. ;;; (in-package "LISP") ;;; ;;; Move the symbol whose name is NAME from LISP to KERNEL, and ;;; fix packages using that symbol. ;;; (defun lisp-symbol->kernel (name) (let ((sym (find-symbol name :lisp))) (ext:collect ((pkgs)) (dolist (p (list-all-packages)) (when (eq (find-symbol name p) sym) (pkgs p))) (unexport sym :lisp) (unintern sym :lisp) (import sym :kernel) (dolist (p (pkgs)) (unless (eq (find-symbol name p) sym) (import sym p)))))) ;;; ;;; Move symbols we want to end up in KERNEL from LISP to KERNEL. ;;; (defvar *symbols-to-move* '("CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF")) (mapc #'lisp-symbol->kernel *symbols-to-move*) ;;; ;;; Redefine MAKE-PACKAGE because cross-compilation and build scripts ;;; rename some packages and make new ones. We want to make sure that ;;; the new packages contain the symbols we imported from KERNEL ;;; in LISP-SYMBOL->KERNEL into the old package. ;;; (defun make-package (name &key (use *default-package-use-list*) nicknames (internal-symbols 10) (external-symbols 10)) "Makes a new package having the specified Name and Nicknames. The package will inherit all external symbols from each package in the use list. :Internal-Symbols and :External-Symbols are estimates for the number of internal and external symbols which will ultimately be present in the package." (when (find-package name) (cerror "Leave existing package alone." "A package named ~S already exists" name)) (let* ((name (package-namify name)) (package (internal-make-package :%name name :internal-symbols (make-package-hashtable internal-symbols) :external-symbols (make-package-hashtable external-symbols)))) (if *in-package-init* (push (list use package) *deferred-use-packages*) (use-package use package)) (enter-new-nicknames package nicknames) (setf (gethash name *package-names*) package) (let ((old-pkg (find-package (concatenate 'string "OLD-" name)))) (when (and old-pkg (find-symbol (car *symbols-to-move*) old-pkg)) (dolist (sym *symbols-to-move*) (import (find-symbol sym "KERNEL") package)))) package)) (in-package :kernel) (export '(%class-layout %class-name %class-state %class-direct-superclasses %class-subclasses %class-pcl-class)) ;;; ;;; Like DEFSTRUCT, but silently clobber old definitions. ;;; (defmacro defstruct! (name &rest stuff) `(handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct ,name ,@stuff))) ;;; ;;; Redefine CLASS in the compiling Lisp. ;;; (defstruct! (class (:conc-name %class-) (:make-load-form-fun class-make-load-form-fun) (:print-function %print-class) (:include ctype (:class-info (type-class-or-lose 'class))) (:pure nil)) (name nil) (layout nil :type (or layout null)) (state nil :type (member nil :read-only :sealed)) (direct-superclasses () :type list) (subclasses nil :type (or hash-table null)) (pcl-class nil)) ;;; ;;; Provide old accessors so that the compiling Lisp continues ;;; to work. ;;; (macrolet ((def (o n) `(progn (defun ,o (x) (,n x)) (defun (setf ,o) (v x) (setf (,n x) v))))) (def class-layout %class-layout) (def class-name %class-name) (def class-state %class-state) (def class-direct-subclasses %class-direct-superclasses) (def class-subclasses %class-subclasses)) ;;; ;;; This build feature is checked in code:class.lisp, and makes it ;;; define the same accessors as above. ;;; (pushnew :bootstrap-lisp-class=pcl-class *features*) ;;; ;;; Redefine other affected structs. ;;; (defstruct! (undefined-class (:include class) (:constructor make-undefined-class (name)))) (defstruct! (built-in-class (:include class)) (translation nil :type (or ctype (member nil :initializing)))) (defstruct! (slot-class (:include class)) (print-function nil :type (or function symbol null))) (defstruct! (basic-structure-class (:include slot-class))) (defstruct! (structure-class (:include basic-structure-class)) (make-load-form-fun nil :type (or function symbol (member :just-dump-it-normally :ignore-it nil))) (constructor nil :type (or function null))) (defstruct! (funcallable-structure-class (:include basic-structure-class))) (defstruct! (std-class (:include class))) (defstruct! (standard-class (:include std-class))) (defstruct! (random-pcl-class (:include std-class))) (in-package "CONDITIONS") (kernel::defstruct! (condition-class (:include slot-class)) (slots nil :type list) (class-slots nil :type list) (report nil :type (or function null)) (default-initargs () :type list) (cpl () :type list) (hairy-slots nil :type list)) ;;; end of file cmucl-21a/src/bootfiles/18e/boot10.lisp000066400000000000000000000077561260377556400177470ustar00rootroot00000000000000;;; ;;; Bootstrap.lisp for changing slot %NAME of DEFSTRUCT-SLOT-DESCRIPTION ;;; to NAME, and making NAME hold the slot name symbol instead ;;; of a string. This is necessary for a conforming SLOT-EXISTS-P ;;; and MAKE-LOAD-FORM-SAVING-SLOTS. ;;; ;;; The build is unusual in that it requires two full builds with the ;;; same bootstrap file in a row, that is: ;;; ;;; 1. Copy this file to target:bootstrap.lisp and do a full build. ;;; Choose the CLOBBER-IT restart when asked. For an unknown ;;; reason, it doesn't work to do this programatically. ;;; ;;; 2. Leave the bootstrap file where it is and do a full build with ;;; the Lisp produced by step 1. ;;; ;;; 3. Remove the bootstrap file, and build again. ;;; (in-package :kernel) (setq *ANSI-defstruct-options-p* nil) (defun define-class-methods (defstruct) (let* ((name (dd-name defstruct))) `(,@(let ((pf (dd-print-function defstruct))) (when pf `((setf (basic-structure-class-print-function (find-class ',name)) ,(if (symbolp pf) `',pf `#',pf))))) ,@(let ((mlff (dd-make-load-form-fun defstruct))) (when mlff `((setf (structure-class-make-load-form-fun (find-class ',name)) ,(if (symbolp mlff) `',mlff `#',mlff))))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure 't) `((setf (layout-pure (%class-layout (find-class ',name))) t))) ((eq pure :substructure) `((setf (layout-pure (%class-layout (find-class ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) `((setf (structure-class-constructor (find-class ',name)) #',def-con))))))) (defstruct (defstruct-slot-description (:conc-name dsd-) (:print-function print-defstruct-slot-description) (:pure t) (:make-load-form-fun :just-dump-it-normally)) name (index (required-argument) :type fixnum) (accessor nil) default (type t) (raw-type t :type (member t single-float double-float #+long-float long-float complex-single-float complex-double-float #+long-float complex-long-float unsigned-byte)) (read-only nil :type (member t nil))) (setf (info type compiler-layout 'defstruct-slot-description) (%class-layout (find-class 'defstruct-slot-description))) (let ((*setf-fdefinition-hook* nil)) (setf (fdefinition 'dsd-name) (lambda (dsd) (let ((name (%instance-ref dsd 1))) (if (stringp name) (intern name (symbol-package (dsd-accessor dsd))) name))))) (defun dsd-%name (dsd) (symbol-name (dsd-name dsd))) (defun parse-1-dsd (defstruct spec &optional (islot (make-defstruct-slot-description :name nil :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) (cond ((listp spec) (destructuring-bind (name &optional (default nil default-p) &key (type nil type-p) (read-only nil ro-p)) spec (values name default default-p type type-p read-only ro-p))) (t (when (keywordp spec) (warn "Keyword slot name indicates probable syntax ~ error in DEFSTRUCT -- ~S." spec)) spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) (error 'simple-program-error :format-control "Duplicate slot name ~S." :format-arguments (list name))) (setf (dsd-name islot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name)) (when default-p (setf (dsd-default islot) default)) (when type-p (setf (dsd-type islot) (if (eq (dsd-type islot) 't) type `(and ,(dsd-type islot) ,type)))) (when ro-p (if read-only (setf (dsd-read-only islot) t) (when (dsd-read-only islot) (error "Slot ~S must be read-only in subtype ~S." name (dsd-name islot))))) islot)) (defun compare-slots (old new) (declare (ignore old new)) (values nil nil nil)) ;;; end of file cmucl-21a/src/bootfiles/18e/boot11.lisp000066400000000000000000000017451260377556400177400ustar00rootroot00000000000000;;; ;;; Boot file for moving PCL's declaration identifiers SLOTS, ;;; AUTO-COMPILE, NOT-AUTO-COMPILE to EXT. Use this file ;;; as target:bootstrap.lisp using Pierre Mai's build scripts. ;;; (in-package :user) (setq lisp::*enable-package-locked-errors* nil) (defun unintern-in-all-packages (name) (dolist (pkg (list-all-packages)) (multiple-value-bind (symbol status) (find-symbol name pkg) (when symbol (unintern symbol pkg))))) (unintern-in-all-packages "SLOTS") (unintern-in-all-packages "AUTO-COMPILE") (unintern-in-all-packages "NOT-AUTO-COMPILE") (in-package :ext) (export '(slots auto-compile not-auto-compile)) (in-package :kernel) (defun compare-slots (old new) (values nil nil nil)) (in-package :conditions) (defstruct (condition-class (:include slot-class)) (slots nil :type list) (class-slots nil :type list) (report nil :type (or function null)) (default-initargs () :type list) (cpl () :type list) (hairy-slots nil :type list)) ;;; end of file cmucl-21a/src/bootfiles/18e/boot12.lisp000066400000000000000000000027211260377556400177340ustar00rootroot00000000000000;;; ;;; Boot file for adding fwrappers, and making TRACE and PROFILE ;;; use fwrappers. To bootstrap, copy this file to target:bootstrap.lisp ;;; using Pierre Mai's build scripts, and do a full build. ;;; (in-package :user) ;;; ;;; Move FDEFN-OR-LOSE to KERNEL and export it from there. ;;; (in-package :lisp) (unless (fboundp 'fdefn-or-lose) (defun fdefn-or-lose (name) "Return the FDEFN of NAME. Signal an error if there is none or if it's function is null." (let ((fdefn (fdefinition-object name nil))) (unless (and fdefn (fdefn-function fdefn)) (error 'undefined-function :name name)) fdefn))) (in-package :user) (setf (fdefinition 'kernel::fdefn-or-lose) (fdefinition 'lisp::fdefn-or-lose)) (unintern 'cl::fdefn-or-lose :cl) (export 'kernel::fdefn-or-lose :kernel) (in-package :profile) (defmacro defstruct! (name &rest stuff) `(handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct ,name ,@stuff))) (defstruct! (profile-info (:conc-name pi-) (:constructor make-profile-info (function-name callers-p))) function-name (callers-p nil :type boolean) (count 0 :type fixnum) (time 0 :type time-type) (consed-h 0 :type dfixnum:dfparttype) (consed-l 0 :type dfixnum:dfparttype) (consed-w/c-h 0 :type dfixnum:dfparttype) (consed-w/c-l 0 :type dfixnum:dfparttype) (profile 0 :type integer) (callers () :type list)) ;;; end of file cmucl-21a/src/bootfiles/18e/boot13.lisp000066400000000000000000000333711260377556400177420ustar00rootroot00000000000000;;; ;;; Boot file for removing the "" nickname of the KEYWORD package, ;;; removing the USER nickname from CL-USER, and removing the ;;; LISP nickname from COMMON-LISP, the latter by introducing ;;; a new COMMON-LISP package which LISP uses. ;;; ;;; To bootstrap, copy this file to target:bootstrap.lisp ;;; using Pierre Mai's build scripts, and do a full build. ;;; (in-package :lisp) #+relative-package-names (defun relative-package-name-to-package (name) (declare (simple-string name) (optimize (speed 3))) (flet ((relative-to (package name) (declare (type package package) (simple-string name)) (if (string= "" name) package (let ((parent-name (package-%name package))) (unless parent-name (error "Can't do anything to a deleted package: ~S" package)) (package-name-to-package (concatenate 'simple-string parent-name "." name))))) (find-non-dot (name) (do* ((len (length name)) (i 0 (1+ i))) ((= i len) nil) (declare (type index len i)) (when (char/= #\. (schar name i)) (return i))))) (when (and (plusp (length name)) (char= #\. (schar name 0))) (let* ((last-dot-position (or (find-non-dot name) (length name))) (n-dots last-dot-position) (name (subseq name last-dot-position))) (cond ((= 1 n-dots) ;; relative to current package (relative-to *package* name)) (t ;; relative to our (- n-dots 1)'th parent (let ((package *package*) (tmp nil)) (dotimes (i (1- n-dots)) (declare (fixnum i)) (setq tmp (package-parent package)) (unless tmp (error 'simple-package-error :name (string package) :format-control "The parent of ~a does not exist." :format-arguments (list package))) (setq package tmp)) (relative-to package name)))))))) (defun read-token (stream firstchar) "This function is just an fsm that recognizes numbers and symbols." ;;check explicitly whether firstchar has entry for non-terminating ;;in character-attribute-table and read-dot-number-symbol in CMT. ;;Report an error if these are violated (if we called this, we want ;;something that is a legitimate token!). ;;read in the longest possible string satisfying the bnf for ;;"unqualified-token". Leave the result in the READ-BUFFER. ;;Return next char after token (last char read). (when *read-suppress* (internal-read-extended-token stream firstchar nil) (return-from read-token nil)) (let ((attribute-table (character-attribute-table *readtable*)) (package nil) (colons 0) (possibly-rational t) (possibly-float t) (escapes ())) (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-table) (#.constituent-sign (go SIGN)) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-dot (go FRONTDOT)) (#.escape (go ESCAPE)) (#.package-delimiter (go COLON)) (#.multiple-escape (go MULT-ESCAPE)) ;;can't have eof, whitespace, or terminating macro as first char! (t (go SYMBOL))) SIGN ;;saw "sign" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (setq possibly-rational t possibly-float t) (case (char-class3 char attribute-table) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-dot (go SIGNDOT)) (#.escape (go ESCAPE)) (#.package-delimiter (go COLON)) (#.multiple-escape (go MULT-ESCAPE)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (t (go SYMBOL))) LEFTDIGIT ;;saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) (case (char-class3 char attribute-table) (#.constituent-digit (go LEFTDIGIT)) (#.constituent-dot (if possibly-float (go MIDDLEDOT) (go SYMBOL))) (#.constituent-expt (go EXPONENT)) (#.constituent-slash (if possibly-rational (go RATIO) (go SYMBOL))) (#.delimiter (unread-char char stream) (return (make-integer))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) MIDDLEDOT ;;saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (let ((*read-base* 10)) (make-integer)))) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-expt (go EXPONENT)) (#.delimiter (unread-char char stream) (return (let ((*read-base* 10)) (make-integer)))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RIGHTDIGIT ;;saw "[sign] {digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-expt (go EXPONENT)) (#.delimiter (unread-char char stream) (return (make-float))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) SIGNDOT ;;saw "[sign] dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (t (go SYMBOL))) FRONTDOT ;;saw "dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "Dot context error.")) (case (char-class char attribute-table) (#.constituent-digit (go RIGHTDIGIT)) (#.constituent-dot (go DOTS)) (#.delimiter (%reader-error stream "Dot context error.")) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPONENT (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-sign (go EXPTSIGN)) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPTSIGN ;;we got to EXPONENT, and saw a sign character. (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) EXPTDIGIT ;;got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) (#.constituent-digit (go EXPTDIGIT)) (#.delimiter (unread-char char stream) (return (make-float))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RATIO ;;saw "[sign] {digit}+ slash" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class2 char attribute-table) (#.constituent-digit (go RATIODIGIT)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) RATIODIGIT ;;saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio))) (case (char-class2 char attribute-table) (#.constituent-digit (go RATIODIGIT)) (#.delimiter (unread-char char stream) (return (make-ratio))) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) DOTS ;;saw "dot {dot}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "Too many dots.")) (case (char-class char attribute-table) (#.constituent-dot (go DOTS)) (#.delimiter (unread-char char stream) (%reader-error stream "Too many dots.")) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) SYMBOL ;;not a dot, dots, or number. (let ((stream (in-synonym-of stream))) (if (lisp-stream-p stream) (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP (ouch-read-buffer char) (setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.escape (done-with-fast-read-char) (go ESCAPE)) (#.delimiter (done-with-fast-read-char) (unread-char char stream) (go RETURN-SYMBOL)) (#.multiple-escape (done-with-fast-read-char) (go MULT-ESCAPE)) (#.package-delimiter (done-with-fast-read-char) (go COLON)) (t (go SYMBOL-LOOP))))) ;; Fundamental-stream. (prog () SYMBOL-LOOP (ouch-read-buffer char) (setq char (stream-read-char stream)) (when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.escape (go ESCAPE)) (#.delimiter (stream-unread-char stream char) (go RETURN-SYMBOL)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL-LOOP)))))) ESCAPE ;;saw an escape. ;;don't put the escape in the read-buffer. ;;read-next char, put in buffer (no case conversion). (let ((nextchar (read-char stream nil nil))) (unless nextchar (reader-eof-error stream "after escape character")) (push ouch-ptr escapes) (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) MULT-ESCAPE (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (escapep char) (setq char (read-char stream t))) (push ouch-ptr escapes) (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) COLON (casify-read-buffer escapes) (unless (zerop colons) (%reader-error stream "Too many colons in ~S" (read-buffer-to-string))) (setq colons 1) (setq package (if (eql (char-class firstchar attribute-table) #.package-delimiter) *keyword-package* (read-buffer-to-string))) (reset-read-buffer) (setq escapes ()) (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (%reader-error stream "Illegal terminating character after a colon, ~S." char)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go INTERN)) (t (go SYMBOL))) INTERN (setq colons 2) (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) (#.delimiter (unread-char char stream) (%reader-error stream "Illegal terminating character after a colon, ~S" char)) (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (%reader-error stream "To many colons after ~S:" package)) (t (go SYMBOL))) RETURN-SYMBOL (casify-read-buffer escapes) (let ((found (if package (find-package package) *package*))) (unless found (error 'reader-package-error :stream stream :format-arguments (list package) :format-control "Package ~S not found.")) (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) (return (intern* read-buffer ouch-ptr found)) (multiple-value-bind (symbol test) (find-symbol* read-buffer ouch-ptr found) (when (eq test :external) (return symbol)) (let ((name (read-buffer-to-string))) (with-simple-restart (continue "Use symbol anyway.") (error 'reader-package-error :stream stream :format-arguments (list name (package-name found)) :format-control (if test "The symbol ~S is not external in the ~A package." "Symbol ~S not found in the ~A package."))) (return (intern name found))))))))) (set-cmt-entry #\: #'read-token) (rename-package "KEYWORD" "KEYWORD" nil) (cl:rename-package "COMMON-LISP-USER" "COMMON-LISP-USER" '("CL-USER")) (unuse-package "COMMON-LISP" "COMMON-LISP-USER") (use-package "LISP" "COMMON-LISP-USER") (rename-package "COMMON-LISP" "COMMON-LISP" nil) (rename-package "COMMON-LISP" "LISP" nil) (make-package "COMMON-LISP" :nicknames '("CL") :use nil) (let ((cl (find-package "CL")) (lisp (find-package "LISP"))) (do-external-symbols (sym lisp) (unintern sym lisp) (let ((syms (list sym))) (import syms cl) (export syms cl) (import syms lisp) (export syms lisp)))) (cl:use-package "CL" "LISP") (in-package :cl-user) ;;; end of file. cmucl-21a/src/bootfiles/18e/boot14.lisp000066400000000000000000000004071260377556400177350ustar00rootroot00000000000000;;; ;;; Bootstrap file for removing the function definition of ;;; FIXNUM, which must not exist according to CLtS. ;;; (in-package :vm) (export 'fixnumize) (when (fboundp 'fixnum) (setf (fdefinition 'fixnumize) (fdefinition 'fixnum))) ;;; End of file.cmucl-21a/src/bootfiles/18e/boot15.lisp000066400000000000000000000007751260377556400177460ustar00rootroot00000000000000;;; ;;; Bootstrap file for adding dynamic-extent rest args. ;;; (in-package :cl-user) (use-package :fwrappers) ;;; ;;; Prevent structure redefinition dialogs. ;;; (define-fwrapper return-nil (&rest args) (call-next-function) nil) (fwrap 'kernel::redefine-layout-warning #'return-nil) (push :bootstrap-dynamic-extent *features*) ;;; ;;; Make compiler-layouts known to the compiler, for the change ;;; in the struct C::LEAF, which gets a new slot. ;;; (compile-file "target:compiler/node") ;;; End of file. cmucl-21a/src/bootfiles/18e/boot16.lisp000066400000000000000000000005631260377556400177420ustar00rootroot00000000000000;;; ;;; Bootstrap file for adding an IR1 attribute. ;;; (in-package :c) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (def-boolean-attribute ir1 call unsafe unwind any foldable flushable movable predicate recursive explicit-check dynamic-extent-closure-safe)) ;;; End of file. cmucl-21a/src/bootfiles/18e/boot17.lisp000066400000000000000000000001341260377556400177350ustar00rootroot00000000000000;; Boot file for adding *runtime-features* (in-package :sys) (defvar *runtime-features* nil)cmucl-21a/src/bootfiles/18e/boot18.lisp000066400000000000000000000034361260377556400177460ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19a. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; (setf (symbol-value 'byte-fasl-file-version) #x19a) (setf (backend-fasl-file-version *target-backend*) #x19a) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) ;;;; end of boot18.lisp cmucl-21a/src/bootfiles/18e/boot19.lisp000066400000000000000000000004151260377556400177410ustar00rootroot00000000000000;; For Sparc only, to make these constants available when building ;; from a release that didn't have these defined. #+sparc (in-package :vm) #+sparc (defconstant pseudo-atomic-value (ash 1 (1- vm:lowtag-bits))) #+sparc (defconstant pseudo-atomic-interrupted-value 1) cmucl-21a/src/bootfiles/18e/boot2.lisp000066400000000000000000000012011260377556400176430ustar00rootroot00000000000000;;; ;;; Bootstrap file 2 of 2 for moving LISP:CLASS and assorted functions ;;; and types to KERNEL, so that they are freed for use by PCL. ;;; ;;; Use this file as bootstrap.lisp, using Pierre Mai's build scripts, ;;; to compile the final Lisp with the cross-compiled Lisp that resulted ;;; from using the first bootstrap file in this series. ;;; (in-package "USER") ;;; ;;; Otherwise PCL barfs when it is built, because it defines generic ;;; functions with the same names. The functions are still there ;;; in the compiling Lisp for bootstrapping reasons. ;;; (fmakunbound 'class-name) (fmakunbound '(setf class-name)) ;;; end of file cmucl-21a/src/bootfiles/18e/boot20-sparc.lisp000066400000000000000000000137231260377556400210450ustar00rootroot00000000000000;;; ;;; Cross-compile bootstrap file for adding heap overflow checking for sparc. ;;; ;;; Use this as the cross-compile script for cross-build-world.sh. ;;; (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") (c::new-backend "SPARC" ;; Features to add here '(:sparc :sparc-v9 :complex-fp-vops :linkage-table :stack-checking :heap-overflow-check :gencgc :conservative-float-type :hash-new :random-mt19937 :cmu :cmu19 :cmu19a ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 :x86 :x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :pentium :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. (pushnew :heap-overflow-check *features*) (pushnew :heap-overflow-check sys::*runtime-features*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) ;; When compiling the compiler, vm:fixup-code-object and ;; vm:sanctify-for-execution are undefined. Import these to get rid ;; of that error. (import 'old-sparc::fixup-code-object) (import 'old-sparc::sanctify-for-execution) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS OLD-SPARC:LOWTAG-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg ;; to the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) cmucl-21a/src/bootfiles/18e/boot20-x86.lisp000066400000000000000000000124521260377556400203600ustar00rootroot00000000000000;;; ;;; Cross-compile bootstrap file for adding heap overflow checking for x86. ;;; ;;; Use this as the cross-compile script for cross-build-world.sh. ;;; (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86") (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here '(:x86 :i486 :pentium :stack-checking :heap-overflow-check :linkage-table :mp :gencgc :conservative-float-type :hash-new :random-mt19937 :linux :glibc2 :glibc2.1 :cmu :cmu18 :cmu18d ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. (pushnew :heap-overflow-check *features*) (pushnew :heap-overflow-check sys::*runtime-features*) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-BIT-VECTOR-TYPE OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'x86::any-reg ht))) cmucl-21a/src/bootfiles/18e/boot21-sparc.lisp000066400000000000000000000154371260377556400210520ustar00rootroot00000000000000;;;; ;;;; This cross-compile script is used for cross-compiling from a ;;;; 2003-12 solaris snapshot to 2004-01-14 (or so) sources. This ;;;; version has a faster gencgc allocator that uses alloc-tn as ;;;; alloc-tn was intended to be used. ;;;; ;;;; It may be possible to make this change without a cross-compile ;;;; but I did not try it. ;;;; ;;;; This is basically a copy of ;;;; src/tools/cross-scripts/cross-sparc-sparc.lisp. ;;;; (in-package :cl-user) ;;; Rename the SPARC package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") (c::new-backend "SPARC" ;; Features to add here '(:sparc :sparc-v9 ; For Ultrasparc processors :complex-fp-vops ; Some slightly faster FP vops on complex numbers :linkage-table :stack-checking ; Throw error if we run out of stack :heap-overflow-check ; Throw error if we run out of heap :gencgc ; Generational GC :relative-package-names ; Relative package names from Allegro :conservative-float-type :hash-new :random-mt19937 ; MT-19937 generator :cmu ; Announce this is CMUCL :cmu19 :cmu19a ; Current version identifier ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 ;; Other architectures we aren't using. :x86 :x86-bootstrap :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type ;; Other OSes were not using :openbsd :freebsd :glibc2 :linux :pentium :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) ;; When compiling the compiler, vm:fixup-code-object and ;; vm:sanctify-for-execution are undefined. Import these to get rid ;; of that error. (import 'old-sparc::fixup-code-object) (import 'old-sparc::sanctify-for-execution) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS OLD-SPARC:LOWTAG-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; Sometimes during cross-compile sparc::any-reg isn't defined during ;; cross-compile. ;; ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg ;; to the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) cmucl-21a/src/bootfiles/18e/boot22.lisp000066400000000000000000000002301260377556400177260ustar00rootroot00000000000000;;; Bootstrap for modular arithmetic. (pushnew :modular-arith *features*) (in-package "KERNEL") (defvar *modular-funs* (make-hash-table :test 'eq)) cmucl-21a/src/bootfiles/18e/boot23-sxhash.lisp000066400000000000000000000004001260377556400212220ustar00rootroot00000000000000;;; Cross-compile bootstrap file for new sxhash function. ;;; ;;; Nothing fancy needed. Just load up the default cross-compile script. #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc") #+x86 (load "target:tools/cross-scripts/cross-x86-x86") cmucl-21a/src/bootfiles/18e/boot24.lisp000066400000000000000000000025041260377556400177360ustar00rootroot00000000000000;;; ;;; Bootstrap file for adding support for source location recording ;;; from Helmut Eller. ;;; (in-package "C") (setf lisp::*enable-package-locked-errors* nil) (defstruct (form-numbers) ;; The tlf-number and form-number encoded in a fixnum. (form-numbers (required-argument) :type fixnum)) (defstruct (file-source-location (:include form-numbers) (:make-load-form-fun :just-dump-it-normally) (:pure t)) (pathname (required-argument) :type simple-string)) (defstruct (stream-source-location (:include form-numbers) (:make-load-form-fun :just-dump-it-normally) (:pure t)) user-info) (defun encode-form-numbers (tlf-number form-number) "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum." (declare (type (unsigned-byte 14) tlf-number form-number)) (logior tlf-number (ash form-number 14))) (defun namestring-for-debug-source (file-info) "Extract the namestring from FILE-INFO for the DEBUG-SOURCE. Return FILE-INFO's untruename (e.g., target:foo) if it is absolute; otherwise the truename." (let* ((untruename (file-info-untruename file-info)) (dir (pathname-directory untruename))) (namestring (if (and dir (eq (first dir) :absolute)) untruename (file-info-name file-info))))) (defun source-location () "Return a source-location for the call site." nil) cmucl-21a/src/bootfiles/18e/boot25.lisp000066400000000000000000000054111260377556400177370ustar00rootroot00000000000000 (setf lisp::*enable-package-locked-errors* nil) (in-package :c) ;;; Used to record the source-location of definitions. ;;; (define-info-class source-location) (define-info-type source-location defvar (or form-numbers null) nil) (in-package :lisp) ;;; DEFCONSTANT -- Public ;;; (defmacro defconstant (var val &optional doc) "For defining global constants at top level. The DEFCONSTANT says that the value is constant and may be compiled into code. If the variable already has a value, and this is not equal to the init, an error is signalled. The third argument is an optional documentation string for the variable." `(progn (eval-when (:compile-toplevel) (c::do-defconstant-compile-time ',var ,val ',doc)) (eval-when (:load-toplevel :execute) (c::%%defconstant ',var ,val ',doc (c::source-location))))) (defun set-defvar-source-location (name source-location) (setf (info :source-location :defvar name) source-location)) ;;; %Defconstant, %%Defconstant -- Internal ;;; ;;; Like the other %mumbles except that we currently actually do something ;;; interesting at load time, namely checking if the constant is being ;;; redefined. ;;; (defun c::%defconstant (name value doc) (c::%%defconstant name value doc nil)) ;;; (defun c::%%defconstant (name value doc source-location) (when doc (setf (documentation name 'variable) doc)) (when (boundp name) (unless (equalp (symbol-value name) value) (cerror "Go ahead and change the value." "Constant ~S being redefined." name))) (setf (symbol-value name) value) (setf (info variable kind name) :constant) (clear-info variable constant-value name) (set-defvar-source-location name source-location) name) (defmacro defvar (var &optional (val nil valp) (doc nil docp)) "For defining global variables at top level. Declares the variable SPECIAL and, optionally, initializes it. If the variable already has a value, the old value is not clobbered. The third argument is an optional documentation string for the variable." `(progn (declaim (special ,var)) ,@(when valp `((unless (boundp ',var) (setq ,var ,val)))) ,@(when docp `((setf (documentation ',var 'variable) ',doc))) (set-defvar-source-location ',var (c::source-location)) ',var)) (defmacro defparameter (var val &optional (doc nil docp)) "Defines a parameter that is not normally changed by the program, but that may be changed without causing an error. Declares the variable special and sets its value to VAL. The third argument is an optional documentation string for the parameter." `(progn (declaim (special ,var)) (setq ,var ,val) ,@(when docp `((setf (documentation ',var 'variable) ',doc))) (set-defvar-source-location ',var (c::source-location)) ',var)) cmucl-21a/src/bootfiles/18e/boot26.lisp000066400000000000000000000003101260377556400177310ustar00rootroot00000000000000(in-package :cl-user) (ext:without-package-locks (unintern 'lisp::simple-stream-error :lisp) (unintern 'conditions::simple-stream-error :conditions) (export 'kernel::simple-stream-error :kernel)) cmucl-21a/src/bootfiles/18e/boot3.lisp000066400000000000000000000024041260377556400176520ustar00rootroot00000000000000;;;; ;;;; Boot file for control stack checking, except that there is no ;;;; boot file necessary, only a normal cross-compilation. ;;;; ;;;; Stack checking is implemented and known to work on FreeBSD 4/x86 ;;;; and Debian 2.2.20/86 only, and it is optional, that is, one ;;;; should be able to build with or without it. ;;;; ;;;; Using Pierre Mai's build scripts, assuming your source directory ;;;; is called src-head, and your fasl directories are called ;;;; fasl-head and cross-fasl-head: ;;;; ;;;; -- Add :STACK-CHECKING to fasl-head/setenv.lisp. ;;;; ;;;; -- Add :STACK-CHECKING to your cross-compilation script, ;;;; where it has ;;;; ;;;; (c::new-backend "X86" ;;;; '(... :stack-checking ...) ;;;; '(...)) ;;;; ;;;; -- Change occurrences of KERNEL:CLASS-LAYOUT in your ;;;; cross-compilation script to KERNEL:%CLASS-LAYOUT. ;;;; ;;;; -- Cross-compile to fasl-head via cross-fasl-head. This will fail ;;;; and tell you that the C header file has changed. Build a new ;;;; runtime, and start over. ;;;; ;;;; NB: If your source directory is not called "src", make sure that ;;;; fasl-head/lisp/Config refers to the directory you are actually ;;;; using, src-head in this example. ;;;; ;;;; -- Do a full normal compile with the result of the ;;;; cross-compilation. ;;;; cmucl-21a/src/bootfiles/18e/boot4.lisp000066400000000000000000000004151260377556400176530ustar00rootroot00000000000000;;;; ;;;; Boot file for making C::SEQUENCE-COUNT = KERNEL:SEQUENCE-COUNT, ;;;; which it should be because KERNEL:SEQUENCE-COUNT names a type ;;;; used in the compiler. ;;;; (unintern 'c::sequence-count "C") (export '(kernel::sequence-count) :kernel) ;;;; end of file cmucl-21a/src/bootfiles/18e/boot5.lisp000066400000000000000000000212761260377556400176640ustar00rootroot00000000000000;;; ;;; Bootfile for changes in macro lambda-list processing. ;;; Destructuring in &REST, &BODY, and &WHOLE. Addition ;;; of EXT:&PARSE-BODY. ;;; (in-package :lisp) (defun parse-defmacro-lambda-list (lambda-list arg-list-name name error-kind error-fun &optional top-level env-illegal env-arg-name) (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) (now-processing :required) (maximum 0) (minimum 0) (keys ()) rest-name restp allow-other-keys-p env-arg-used) ;; This really strange way to test for '&whole is neccessary because member ;; does not have to work on dotted lists, and dotted lists are legal ;; in lambda-lists. (when (and (do ((list lambda-list (cdr list))) ((atom list) nil) (when (eq (car list) '&whole) (return t))) (not (eq (car lambda-list) '&whole))) (simple-program-error "&Whole must appear first in ~S lambda-list." error-kind)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((atom rest-of-args) (cond ((null rest-of-args) nil) ;; Varlist is dotted, treat as &rest arg and exit. (t (push-let-binding rest-of-args path nil) (setf restp :dotted)))) (let ((var (car rest-of-args))) (cond ((eq var '&whole) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) ;; For compiler macros, we have to do something ;; special in case the form has a car eq to ;; funcall, as specified in the CLHS. In this ;; case, we skip over the funcall and pretend ;; that the rest of the form is the actual form. ;; ;; This is a gross hack because we look at ;; error-kind to figure out if we're defining a ;; compiler macro or not. (when (eq error-kind 'define-compiler-macro) (push-let-binding arg-list-name arg-list-name t `(progn (not (and (listp ,arg-list-name) (eq 'funcall (car ,arg-list-name))))) `(progn (setf ,arg-list-name (cdr ,arg-list-name))))) (push-let-binding (car rest-of-args) arg-list-name nil)) ((and (cdr rest-of-args) (consp (cadr rest-of-args))) (pop rest-of-args) (let* ((destructuring-lambda-list (car rest-of-args)) (sub (gensym "WHOLE-SUBLIST"))) (push-sub-list-binding sub arg-list-name destructuring-lambda-list name error-kind error-fun) (parse-defmacro-lambda-list destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error "&WHOLE" error-kind name)))) ((eq var '&environment) (cond (env-illegal (simple-program-error "&environment not valid with ~S." error-kind)) ((not top-level) (simple-program-error "&environment only valid at top level of lambda-list."))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (push-let-binding (car rest-of-args) env-arg-name nil) (setf env-arg-used t)) (t (defmacro-error "&ENVIRONMENT" error-kind name)))) ;; ;; This branch implements an extension to Common Lisp ;; that was formerly implemented for &body. In place of ;; a symbol following &body, there could be a list of up ;; to three elements which will be bound to the body, ;; declarations, and doc-string of the body. ((eq var 'ext::&parse-body) (unless (and (cdr rest-of-args) (consp (cadr rest-of-args)) (symbolp (caadr rest-of-args))) (simple-program-error "Invalid ~a" 'ext::&parse-body)) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (let ((body-name (caar rest-of-args)) (declarations-name (cadar rest-of-args)) (doc-string-name (caddar rest-of-args)) (parse-body-values (gensym))) (push-let-binding parse-body-values `(multiple-value-list (parse-body ,path ,env-arg-name ,(not (null doc-string-name)))) t) (setf env-arg-used t) (when body-name (push-let-binding body-name `(car ,parse-body-values) nil)) (when declarations-name (push-let-binding declarations-name `(cadr ,parse-body-values) nil)) (when doc-string-name (push-let-binding doc-string-name `(caddr ,parse-body-values) nil)))) ;; ((member var '(&rest &body)) (cond ((and (cddr rest-of-args) (not (member (caddr rest-of-args) lambda-list-keywords))) (defmacro-error (symbol-name var) error-kind name)) ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (push-let-binding (car rest-of-args) path nil)) ((and (cdr rest-of-args) (consp (cadr rest-of-args))) (pop rest-of-args) (setq restp t) (let* ((destructuring-lambda-list (car rest-of-args)) (sub (gensym "REST-SUBLIST"))) (push-sub-list-binding sub path destructuring-lambda-list name error-kind error-fun) (parse-defmacro-lambda-list destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error (symbol-name var) error-kind name)))) ((eq var '&optional) (setf now-processing :optionals)) ((eq var '&key) (setf now-processing :keywords) (setf rest-name (gensym "KEYWORDS-")) (push rest-name *ignorable-vars*) (setf restp t) (push-let-binding rest-name path t)) ((eq var '&allow-other-keys) (setf allow-other-keys-p t)) ((eq var '&aux) (setf now-processing :auxs)) ((listp var) (case now-processing (:required (let ((sub-list-name (gensym "SUBLIST-"))) (push-sub-list-binding sub-list-name `(car ,path) var name error-kind error-fun) (parse-defmacro-lambda-list var sub-list-name name error-kind error-fun)) (setf path `(cdr ,path)) (incf minimum) (incf maximum)) (:optionals (when (> (length var) 3) (cerror "Ignore extra noise." "More than variable, initform, and suppliedp ~ in &optional binding - ~S" var)) (push-optional-binding (car var) (cadr var) (caddr var) `(not (null ,path)) `(car ,path) name error-kind error-fun) (setf path `(cdr ,path)) (incf maximum)) (:keywords (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) (car var))) (keyword (if keyword-given (caar var) (make-keyword variable))) (supplied-p (caddr var))) (push-optional-binding variable (cadr var) supplied-p `(keyword-supplied-p ',keyword ,rest-name) `(lookup-keyword ',keyword ,rest-name) name error-kind error-fun) (push keyword keys))) (:auxs (push-let-binding (car var) (cadr var) nil)))) ((symbolp var) (case now-processing (:required (incf minimum) (incf maximum) (push-let-binding var `(car ,path) nil) (setf path `(cdr ,path))) (:optionals (incf maximum) (push-let-binding var `(car ,path) nil `(not (null ,path))) (setf path `(cdr ,path))) (:keywords (let ((key (make-keyword var))) (push-let-binding var `(lookup-keyword ,key ,rest-name) nil) (push key keys))) (:auxs (push-let-binding var nil nil)))) (t (simple-program-error "Non-symbol in lambda-list - ~S." var))))) ;; Generate code to check the number of arguments, unless dotted ;; in which case length will not work. (unless (eq restp :dotted) (push `(unless (<= ,minimum (length (the list ,(if top-level `(cdr ,arg-list-name) arg-list-name))) ,@(unless restp (list maximum))) ,(let ((arg (if top-level `(cdr ,arg-list-name) arg-list-name))) (if (eq error-fun 'error) `(do-arg-count-error ',error-kind ',name ,arg ',lambda-list ,minimum ,(unless restp maximum)) `(,error-fun 'defmacro-ll-arg-count-error :kind ',error-kind ,@(when name `(:name ',name)) :argument ,arg :lambda-list ',lambda-list :minimum ,minimum ,@(unless restp `(:maximum ,maximum)))))) *arg-tests*)) (if keys (let ((problem (gensym "KEY-PROBLEM-")) (info (gensym "INFO-"))) (push `(multiple-value-bind (,problem ,info) (verify-keywords ,rest-name ',keys ',allow-other-keys-p) (when ,problem (,error-fun 'defmacro-ll-broken-key-list-error :kind ',error-kind ,@(when name `(:name ',name)) :problem ,problem :info ,info))) *arg-tests*))) (values env-arg-used minimum (if (null restp) maximum nil)))) ;;; end of file cmucl-21a/src/bootfiles/18e/boot6.lisp000066400000000000000000000042761260377556400176660ustar00rootroot00000000000000;;;; ;;;; This boot-file is needed only when cross-compiling from a lisp which ;;;; doesn't have the type-union related type-system changes to one which ;;;; has. If one does a normal recompile to do the update, this isn't ;;;; needed, but if one wants to e.g. go from 18e directly to current HEAD, ;;;; a cross-compile is necessary, as is this boot file. ;;;; ;;;; This needs to be placed in the target:bootstrap.lisp file, while doing ;;;; the cross-compile, which is loaded after compiling the cross-compiler, ;;;; unlike the target:cross-bootstrap.lisp file. ;;;; (in-package :C) (defun make-canonical-union-type (type-list) (let ((members '()) (misc-types '())) (dolist (type type-list) (if (member-type-p type) (setf members (union members (member-type-members type))) (push type misc-types))) #+long-float (when (null (set-difference '(-0l0 0l0) members)) #-negative-zero-is-not-zero (push (specifier-type '(long-float 0l0 0l0)) misc-types) #+negative-zero-is-not-zero (push (specifier-type '(long-float -0l0 0l0)) misc-types) (setf members (set-difference members '(-0l0 0l0)))) (when (null (set-difference '(-0d0 0d0) members)) #-negative-zero-is-not-zero (push (specifier-type '(double-float 0d0 0d0)) misc-types) #+negative-zero-is-not-zero (push (specifier-type '(double-float -0d0 0d0)) misc-types) (setf members (set-difference members '(-0d0 0d0)))) (when (null (set-difference '(-0f0 0f0) members)) #-negative-zero-is-not-zero (push (specifier-type '(single-float 0f0 0f0)) misc-types) #+negative-zero-is-not-zero (push (specifier-type '(single-float -0f0 0f0)) misc-types) (setf members (set-difference members '(-0f0 0f0)))) (cond ((null members) (let ((res (first misc-types))) (dolist (type (rest misc-types)) (setq res (type-union res type))) res)) ((null misc-types) (make-member-type :members members)) (t (let ((res (first misc-types))) (dolist (type (rest misc-types)) (setq res (type-union res type))) (dolist (type members) (setq res (type-union res (make-member-type :members (list type))))) res))))) cmucl-21a/src/bootfiles/18e/boot7.lisp000066400000000000000000000114421260377556400176600ustar00rootroot00000000000000;;; ;;; Bootfile for adding a documentation slot to CONDITION-SLOT. ;;; Use this file as bootstrap.lisp using Pierre Mai's build scripts, ;;; (in-package :conditions) ;;; ;;; Like DEFSTRUCT, but silently clobber old definitions. ;;; (defmacro defstruct! (name &rest stuff) `(handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct ,name ,@stuff))) ;;; ;;; Add the documentation slot. ;;; (defstruct! condition-slot (name (required-argument) :type symbol) (initargs (required-argument) :type list) (readers (required-argument) :type list) (writers (required-argument) :type list) (initform-p (required-argument) :type (member t nil)) (initform (required-argument) :type t) (allocation nil :type (member :instance :class nil)) (cell nil :type (or cons null)) (documentation nil :type (or null string))) ;;; ;;; Parse the :DOCUMENTATION slot option. ;;; (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) (let* ((parent-types (or parent-types '(condition))) (layout (find-condition-layout name parent-types)) (documentation nil) (report nil) (slot-name/accessors ()) (default-initargs ())) (collect ((slots) (all-readers nil append) (all-writers nil append)) (dolist (spec slot-specs) (when (keywordp spec) (warn "Keyword slot name indicates probable syntax error:~% ~S" spec)) (let* ((spec (if (consp spec) spec (list spec))) (slot-name (first spec)) (allocation :instance) (documentation nil) (initform-p nil) initform) (collect ((initargs) (readers) (writers)) (do ((options (rest spec) (cddr options))) ((null options)) (unless (and (consp options) (consp (cdr options))) (simple-program-error "Malformed condition slot spec:~% ~S." spec)) (let ((arg (second options))) (case (first options) (:reader (readers arg)) (:writer (writers arg)) (:accessor (readers arg) (writers `(setf ,arg))) (:initform (when initform-p (simple-program-error "More than one :INITFORM in:~% ~S" spec)) (setq initform-p t) (setq initform arg)) (:initarg (initargs arg)) (:allocation (setq allocation arg)) (:documentation (when documentation (simple-program-error "More than one slot :DOCUMENTATION in~% ~s" spec)) (unless (stringp arg) (simple-program-error "Slot :DOCUMENTATION is not a string in~% ~s" spec)) (setq documentation arg)) (:type) (t (simple-program-error "Unknown slot option:~% ~S" (first options)))))) (push (list slot-name (readers) (writers)) slot-name/accessors) (all-readers (readers)) (all-writers (writers)) (slots `(make-condition-slot :name ',slot-name :initargs ',(initargs) :readers ',(readers) :writers ',(writers) :initform-p ',initform-p :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) `#'(lambda () ,initform))))))) (dolist (option options) (unless (consp option) (simple-program-error "Bad option:~% ~S" option)) (case (first option) (:documentation (setq documentation (second option))) (:report (let ((arg (second option))) (setq report (if (stringp arg) `#'(lambda (condition stream) (declare (ignore condition)) (write-string ,arg stream)) `#'(lambda (condition stream) (funcall #',arg condition stream)))))) (:default-initargs (do ((initargs (rest option) (cddr initargs))) ((endp initargs)) (let ((val (second initargs))) (setq default-initargs (list* `',(first initargs) (if (constantp val) `',(eval val) `#'(lambda () ,val)) default-initargs))))) (t (simple-program-error "Unknown option: ~S" (first option))))) `(progn (eval-when (compile load eval) (%compiler-define-condition ',name ',parent-types ',layout)) (declaim (ftype (function (t) t) ,@(all-readers))) (declaim (ftype (function (t t) t) ,@(all-writers))) ,@(when *make-condition-accessor-methods* (collect ((methods)) (dolist (elt slot-name/accessors) (destructuring-bind (slot-name readers writers) elt (dolist (reader readers) (methods (make-condition-accessor reader name slot-name 'reader t))) (dolist (writer writers) (methods (make-condition-accessor writer name slot-name 'writer t))))) (methods))) (%define-condition ',name (list ,@(slots)) ,documentation ,report (list ,@default-initargs)))))) ;;; end of file cmucl-21a/src/bootfiles/18e/boot8.lisp000066400000000000000000000024051260377556400176600ustar00rootroot00000000000000;;; ;;; Bootfile for adding package locks. ;;; Use this file as bootstrap.lisp using Pierre Mai's build scripts, ;;; (in-package :lisp) ;; Ensure all packages have been set up, since package definition is broken ;; once this file has been loaded: (load "target:code/exports") (defvar *enable-package-locked-errors* nil) ;;; ;;; Like DEFSTRUCT, but silently clobber old definitions. ;;; (defmacro defstruct! (name &rest stuff) `(handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct ,name ,@stuff))) (defstruct! (package (:constructor internal-make-package) (:predicate packagep) (:print-function %print-package) (:make-load-form-fun (lambda (package) (values `(package-or-lose ',(package-name package)) nil)))) (tables (list nil)) (%name nil :type (or simple-string null)) (%nicknames () :type list) (%use-list () :type list) (%used-by-list () :type list) (internal-symbols (required-argument) :type package-hashtable) (external-symbols (required-argument) :type package-hashtable) (%shadowing-symbols () :type list) (lock nil :type boolean) (definition-lock nil :type boolean) (doc-string nil :type (or simple-string null))) ;;; end of file cmucl-21a/src/bootfiles/18e/boot9.lisp000066400000000000000000000034031260377556400176600ustar00rootroot00000000000000;;; Bootstrap file for callback support ;;; ;;; (in-package :alien) ;;; Some abbreviations for alien-type classes. The $ suffix is there ;;; to prevent name clashes. (deftype void$ () '(satisfies alien-void-type-p)) (deftype integer$ () 'alien::alien-integer-type) (deftype integer-64$ () '(satisfies alien-integer-64-type-p)) (deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) (deftype pointer$ () 'alien::alien-pointer-type) (deftype single$ () 'alien::alien-single-float-type) (deftype double$ () 'alien::alien-double-float-type) (deftype sap$ () '(satisfies alien-sap-type=)) (defun alien-sap-type= (type) (alien::alien-type-= type (alien::parse-alien-type 'system-area-pointer))) (defun alien-void-type-p (type) (and (alien::alien-values-type-p type) (null (alien::alien-values-type-values type)))) (defun alien-integer-64-type-p (type) (and (alien::alien-integer-type-p type) (= (alien::alien-type-bits type) 64))) (defun alien-signed-integer-type-p (type) (and (alien::alien-integer-type-p type) (alien::alien-integer-type-signed type))) (defun segment-to-trampoline (segment length) (let* ((code (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) length)) (fill-pointer code)) (new-assem:segment-map-output segment (lambda (sap length) (kernel:system-area-copy sap 0 fill-pointer 0 (* length vm:byte-bits)) (setf fill-pointer (sys:sap+ fill-pointer length)))) code)) (in-package :vm) (export '(make-callback-trampoline callback-accessor-form)) ;; Just define the function for bootstrap. The real one will get ;; defined later. (defun make-callback-trampoline (index return-type) ) (defun callback-accessor-form (type sp offset) ) cmucl-21a/src/bootfiles/19a/000077500000000000000000000000001260377556400157305ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19a/boot-19b.lisp000066400000000000000000000034361260377556400201630ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19b. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; (setf (symbol-value 'byte-fasl-file-version) #x19b) (setf (backend-fasl-file-version *target-backend*) #x19b) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) ;;;; end of boot18.lisp cmucl-21a/src/bootfiles/19a/boot-2004-10-1-ppc.lisp000066400000000000000000000003371260377556400213060ustar00rootroot00000000000000;; Cross-compile script for moving the static space on ppc/darwin. We ;; don't need to do anything special, just load the standard ppc ;; cross-compile script. (load "target:tools/cross-scripts/cross-ppc-ppc-darwin.lisp") cmucl-21a/src/bootfiles/19a/boot-2004-10-2.lisp000066400000000000000000000003701260377556400205240ustar00rootroot00000000000000;;; Bootfile to bootstrap the fixes to loop to handle loop intializers ;;; correctly. (See cmucl-imp, 2004-08-20.) Might be something ;;; simpler, but this is easy. (setf lisp::*enable-package-locked-errors* nil) (load "target:code/loop.lisp") cmucl-21a/src/bootfiles/19a/boot-2005-02-1-sparc.lisp000066400000000000000000000004051260377556400216320ustar00rootroot00000000000000;; Cross-compile bootfile used to change the gtemp register from %g7 ;; (reserved) to reg l0. L0 is no longer used by Lisp for anything. ;; Don't need anything special, so the default sample script is ok. (load "target:tools/cross-scripts/cross-sparc-sparc") cmucl-21a/src/bootfiles/19a/boot-2005-02-ppc-linkage.lisp000066400000000000000000000226501260377556400225640ustar00rootroot00000000000000(in-package "CL-USER") ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "PPC" "OLD-PPC") (setf (c:backend-name c:*native-backend*) "OLD-PPC") ;;; PPC to PPC current cross compile. (c::new-backend "PPC" ;; Features to add here '(:ppc :new-assembler :hash-new :random-mt19937 :cmu19 :cmu19a :ppc :darwin :bsd :relative-package-names :modular-arith :conservative-float-type :linkage-table) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :pentium :elf :mp :stack-checking :heap-overflow-check :gencgc :cgc :long-float :new-random :small) ) #| (load "target:tools/setup" :if-source-newer :load-source) (comf "target:tools/setup" :load t) |# (setf *interactive* nil) (setf *gc-verbose* nil) ;;; Extern-alien-name for the new backend. (in-package "VM") (defun extern-alien-name (name) (declare (type simple-base-string name)) #+darwin (concatenate 'string "_" name) #-darwin (concatenate 'string "" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package "CL-USER") ;;; So compilation of make-fixup will work. (setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") (comf "target:code/foreign-linkage") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:ppc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/ppc/")) ;;; Note: may need to add extra files to load to loadbackend, perhaps ;;; float-tran and srctran; try to follow the order in comcom as this ;;; is often important. ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "target:code/foreign-linkage") (load "target:compiler/dump") (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-BIT-VECTOR-TYPE OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET OLD-PPC:CERROR-TRAP OLD-PPC:ERROR-TRAP OLD-PPC::LOWTAG-BITS OLD-PPC:CATCH-BLOCK-SIZE )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Ready to build. (pushnew :bootstrap *features*) #+nil (let* ((old-package :old-sparc) (sym (find-symbol "ANY-REG" old-package))) (unintern sym (symbol-package sym)) ;;(import sym :sparc) (import sym old-package) ) ;; hack, hack, hack: Make old-ppc::any-reg the same as ;; ppc::any-reg as an SC. Do this by adding old-ppc::any-reg to ;; the hash table with the same value as ppc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-ppc::any-reg ht) (gethash 'ppc::any-reg ht))) (in-package "ALIEN") (defun %def-alien-variable (lisp-name alien-name type) (setf (info variable kind lisp-name) :alien) (setf (info variable where-from lisp-name) :defined) (clear-info variable constant-value lisp-name) (setf (info variable alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-address ',alien-name :flavor :data)))) (defmacro extern-alien (name type) "Access the alien variable named NAME, assuming it is of type TYPE. This is setfable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) `(%heap-alien ',(make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',alien-name :flavor ',flavor))))) (defmacro with-alien (bindings &body body) "Establish some local alien variables. Each BINDING is of the form: VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. :STATIC The alien is allocated on the heap, and has infinate extent. The alien is allocated at load time, so the same piece of memory is used each time this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." (with-auxiliary-alien-types (dolist (binding (reverse bindings)) (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (let* ((alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) (case opt1 (:extern (values opt1 (guess-alien-name-from-lisp-name symbol))) (:static (values opt1 nil)) (t (values :local opt1)))) (setf body (ecase allocation #+nil (:static (let ((sap (make-symbol (concatenate 'string "SAP-FOR-" (symbol-name symbol))))) `((let ((,sap (load-time-value (%make-alien ...)))) (declare (type system-area-pointer ,sap)) (symbol-macrolet ((,symbol (sap-alien ,sap ,type))) ,@(when initial-value `((setq ,symbol ,initial-value))) ,@body))))) (:extern (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',initial-value :flavor ',flavor)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) (note-local-alien-type ',info ,var) (multiple-value-prog1 (symbol-macrolet ((,symbol (local-alien ',info ,var))) ,@(when initial-value `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var) ))))))))))) (verify-local-auxiliaries-okay) `(compiler-let ((*auxiliary-type-definitions* ',(append *new-auxiliary-types* *auxiliary-type-definitions*))) ,@body))) (defparameter cl-user::*load-stuff* nil) #| (load "target:tools/worldcom") (load "target:tools/comcom") ;;; If worldbuild produces a warning that "The C header file has ;;; changed." then it will be necessary to recompile the C code, and ;;; run worldload again. (load "target:tools/worldbuild") (quit) |# cmucl-21a/src/bootfiles/19a/boot-2005-03-1.lisp000066400000000000000000000001751260377556400205310ustar00rootroot00000000000000(ext:without-package-locks (lisp:unintern 'lisp::indenting-stream-p "LISP") (lisp:intern "INDENTING-STREAM-P" "SYSTEM")) cmucl-21a/src/bootfiles/19a/boot-2005-03-2.lisp000066400000000000000000000000471260377556400205300ustar00rootroot00000000000000(intern "BINARY-TEXT-STREAM" "SYSTEM") cmucl-21a/src/bootfiles/19a/boot-2005-04-1-ppc.lisp000066400000000000000000000002701260377556400213060ustar00rootroot00000000000000;; Cross-compile script to get the new pseudo-atomic scheme. ;; Nothing special, just load up the default script for ppc. #+ppc (load "target:tools/cross-scripts/cross-ppc-ppc-darwin")cmucl-21a/src/bootfiles/19a/boot1-cross.lisp000066400000000000000000000003521260377556400207740ustar00rootroot00000000000000;;; Simple cross-compile script for bootstrapping the addition of a ;;; slot to the weak-pointer object. #+x86 (load "target:tools/cross-scripts/cross-x86-x86.lisp") #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc.lisp") cmucl-21a/src/bootfiles/19a/boot2-cross-sparc.lisp000066400000000000000000000002731260377556400221050ustar00rootroot00000000000000;;; Bootstrap file for renaming the unused slot in symbols to hash, ;;; like on x86 so we can store the sxhash value there. #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc") cmucl-21a/src/bootfiles/19a/boot3.lisp000066400000000000000000000003341260377556400176470ustar00rootroot00000000000000;;; Bootstrap for modular arithmetic. (Taken from 18e/boot22.lisp) ;;; (Primarily for ppc.) #+ppc (pushnew :modular-arith *features*) (in-package "KERNEL") #-+ppc (defvar *modular-funs* (make-hash-table :test 'eq)) cmucl-21a/src/bootfiles/19a/boot4.lisp000066400000000000000000000012111260377556400176430ustar00rootroot00000000000000;; Allocation macro for PPC to abstract out all allocation. #+ppc (in-package "PPC") (setf lisp::*enable-package-locked-errors* nil) #+ppc (defmacro allocation (result-tn size lowtag &key stack-p temp-tn) (declare (ignore stack-p temp-tn)) (let ((alloc-size (gensym))) `(let ((,alloc-size ,size)) (if (logbitp (1- lowtag-bits) ,lowtag) (progn (inst ori ,result-tn alloc-tn ,lowtag)) (progn (inst clrrwi ,result-tn alloc-tn lowtag-bits) (inst ori ,result-tn ,result-tn ,lowtag))) (if (numberp ,alloc-size) (inst addi alloc-tn alloc-tn ,alloc-size) (inst add alloc-tn alloc-tn ,alloc-size))))) cmucl-21a/src/bootfiles/19a/boot6-sxhash.lisp000066400000000000000000000003101260377556400211400ustar00rootroot00000000000000;;; Cross-compile bootstrap file for new sxhash function. ;;; ;;; Nothing fancy needed. Just load up the default cross-compile script. #+ppc (load "target:tools/cross-scripts/cross-ppc-ppc-darwin") cmucl-21a/src/bootfiles/19a/boot7.lisp000066400000000000000000000014341260377556400176550ustar00rootroot00000000000000;; Implement float-accuracy compilation policy (intended for x86). ;; This means that on x86 cmucl will run with double-float precision ;; (53-bit) for all floating-point operations, unless float-accuracy ;; is not 3, in which case extended-float (64-bit) precision will be ;; used. ;; ;; By changing the default to 53-bit, double-float-epsilon really is ;; double-float epsilon. (in-package :extensions) (export '(float-accuracy)) (in-package :c) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant policy-parameter-slots '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) (cspeed . cookie-cspeed) (brevity . cookie-brevity) (debug . cookie-debug) (float-accuracy . cookie-float-accuracy)))) cmucl-21a/src/bootfiles/19b/000077500000000000000000000000001260377556400157315ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19b/boot-19c.lisp000066400000000000000000000034401260377556400201600ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19c. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; (setf (symbol-value 'byte-fasl-file-version) #x19c) (setf (backend-fasl-file-version *target-backend*) #x19c) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) ;;;; end of boot-19c.lisp cmucl-21a/src/bootfiles/19c/000077500000000000000000000000001260377556400157325ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19c/boot-19d.lisp000066400000000000000000000036141260377556400201650ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19d. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; (setf (symbol-value 'byte-fasl-file-version) #x19d) (setf (backend-fasl-file-version *target-backend*) #x19d) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) ;;;; end of boot-19d.lisp cmucl-21a/src/bootfiles/19c/boot-2005-10-1.lisp000066400000000000000000000121521260377556400205270ustar00rootroot00000000000000(in-package :C) (setf lisp::*enable-package-locked-errors* nil) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (def-boolean-attribute ir1 ;; ;; May call functions that are passed as arguments. In order to determine ;; what other effects are present, we must find the effects of all arguments ;; that may be functions. call ;; ;; May incorporate function or number arguments into the result or somehow ;; pass them upward. Note that this applies to any argument that *might* be ;; a function or number, not just the arguments that always are. unsafe ;; ;; May fail to return during correct execution. Errors are O.K. unwind ;; ;; The (default) worst case. Includes all the other bad things, plus any ;; other possible bad thing. If this is present, the above bad attributes ;; will be explicitly present as well. any ;; ;; May be constant-folded. The function has no side effects, but may be ;; affected by side effects on the arguments. e.g. SVREF, MAPC. Functions ;; that side-effect their arguments are not considered to be foldable. ;; Although it would be "legal" to constant fold them (since it "is an error" ;; to modify a constant), we choose not to mark theses functions as foldable ;; in this database. foldable ;; ;; May be eliminated if value is unused. The function has no side effects ;; except possibly CONS. If a function is defined to signal errors, then it ;; is not flushable even if it is movable or foldable. flushable ;; ;; May be moved with impunity. Has no side effects except possibly CONS, and ;; is affected only by its arguments. movable ;; ;; Function is a true predicate likely to be open-coded. Convert any ;; non-conditional uses into (IF T NIL). predicate ;; ;; Inhibit any warning for compiling a recursive definition. [Normally the ;; compiler warns when compiling a recursive definition for a known function, ;; since it might be a botched interpreter stub.] recursive ;; ;; Function does explicit argument type checking, so the declared type should ;; not be asserted when a definition is compiled. explicit-check ;; ;; Safe to stack-allocate function args that are closures. dynamic-extent-closure-safe ;; Return value is important and ignoring it is probably a mistake. ;; This is for things like not using the result of nreverse. This ;; is only for warnings and has no effect on optimization. important-result )) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (function-info (:print-function %print-function-info) (:pure t)) ;; ;; Boolean attributes of this function. (attributes (required-argument) :type attributes) ;; ;; A list of Transform structures describing transforms for this function. (transforms () :type list) ;; ;; A function which computes the derived type for a call to this function by ;; examining the arguments. This is null when there is no special method for ;; this function. (derive-type nil :type (or function null)) ;; ;; A function that does random unspecified code transformations by directly ;; hacking the IR. Returns true if further optimizations of the call ;; shouldn't be attempted. (optimizer nil :type (or function null)) ;; ;; If true, a special-case LTN annotation method that is used in place of the ;; standard type/policy template selection. It may use arbitrary code to ;; choose a template, decide to do a full call, or conspire with the ;; IR2-Convert method to do almost anything. The Combination node is passed ;; as the argument. (ltn-annotate nil :type (or function null)) ;; ;; If true, the special-case IR2 conversion method for this function. This ;; deals with funny functions, and anything else that can't be handled using ;; the template mechanism. The Combination node and the IR2-Block are passed ;; as arguments. (ir2-convert nil :type (or function null)) ;; ;; A list of all the templates that could be used to translate this function ;; into IR2, sorted by increasing cost. (templates nil :type list) ;; ;; If non-null, then this function is a unary type predicate for this type. (predicate-type nil :type (or ctype null)) ;; ;; If non-null, use this function to annotate the known call for the byte ;; compiler. If it returns NIL, then change the call to :full. (byte-annotate nil :type (or function null)) ;; ;; If non-null, use this function to generate the byte code for this known ;; call. This function can only give up if there is a byte-annotate function ;; that arranged for the functional to be pushed onto the stack. (byte-compile nil :type (or function null)) ;; A function computing the constant or literal arguments which are ;; destructively modified by the call. (destroyed-constant-args nil :type (or function null)) )) cmucl-21a/src/bootfiles/19c/boot-2005-11-1.lisp000066400000000000000000000122201260377556400205240ustar00rootroot00000000000000(in-package :C) (setf lisp::*enable-package-locked-errors* nil) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (def-boolean-attribute ir1 ;; ;; May call functions that are passed as arguments. In order to determine ;; what other effects are present, we must find the effects of all arguments ;; that may be functions. call ;; ;; May incorporate function or number arguments into the result or somehow ;; pass them upward. Note that this applies to any argument that *might* be ;; a function or number, not just the arguments that always are. unsafe ;; ;; May fail to return during correct execution. Errors are O.K. unwind ;; ;; The (default) worst case. Includes all the other bad things, plus any ;; other possible bad thing. If this is present, the above bad attributes ;; will be explicitly present as well. any ;; ;; May be constant-folded. The function has no side effects, but may be ;; affected by side effects on the arguments. e.g. SVREF, MAPC. Functions ;; that side-effect their arguments are not considered to be foldable. ;; Although it would be "legal" to constant fold them (since it "is an error" ;; to modify a constant), we choose not to mark theses functions as foldable ;; in this database. foldable ;; ;; May be eliminated if value is unused. The function has no side effects ;; except possibly CONS. If a function is defined to signal errors, then it ;; is not flushable even if it is movable or foldable. flushable ;; ;; May be moved with impunity. Has no side effects except possibly CONS, and ;; is affected only by its arguments. movable ;; ;; Function is a true predicate likely to be open-coded. Convert any ;; non-conditional uses into (IF T NIL). predicate ;; ;; Inhibit any warning for compiling a recursive definition. [Normally the ;; compiler warns when compiling a recursive definition for a known function, ;; since it might be a botched interpreter stub.] recursive ;; ;; Function does explicit argument type checking, so the declared type should ;; not be asserted when a definition is compiled. explicit-check ;; ;; Safe to stack-allocate function args that are closures. dynamic-extent-closure-safe )) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (function-info (:print-function %print-function-info) (:pure t)) ;; ;; Boolean attributes of this function. (attributes (required-argument) :type attributes) ;; ;; A list of Transform structures describing transforms for this function. (transforms () :type list) ;; ;; A function which computes the derived type for a call to this function by ;; examining the arguments. This is null when there is no special method for ;; this function. (derive-type nil :type (or function null)) ;; ;; A function that does random unspecified code transformations by directly ;; hacking the IR. Returns true if further optimizations of the call ;; shouldn't be attempted. (optimizer nil :type (or function null)) ;; ;; If true, a special-case LTN annotation method that is used in place of the ;; standard type/policy template selection. It may use arbitrary code to ;; choose a template, decide to do a full call, or conspire with the ;; IR2-Convert method to do almost anything. The Combination node is passed ;; as the argument. (ltn-annotate nil :type (or function null)) ;; ;; If true, the special-case IR2 conversion method for this function. This ;; deals with funny functions, and anything else that can't be handled using ;; the template mechanism. The Combination node and the IR2-Block are passed ;; as arguments. (ir2-convert nil :type (or function null)) ;; ;; A list of all the templates that could be used to translate this function ;; into IR2, sorted by increasing cost. (templates nil :type list) ;; ;; If non-null, then this function is a unary type predicate for this type. (predicate-type nil :type (or ctype null)) ;; ;; If non-null, use this function to annotate the known call for the byte ;; compiler. If it returns NIL, then change the call to :full. (byte-annotate nil :type (or function null)) ;; ;; If non-null, use this function to generate the byte code for this known ;; call. This function can only give up if there is a byte-annotate function ;; that arranged for the functional to be pushed onto the stack. (byte-compile nil :type (or function null)) ;; A function computing the constant or literal arguments which are ;; destructively modified by the call. (destroyed-constant-args nil :type (or function null)) ;; If non-null, use this function to determine if the result of the ;; function is used or not. This is used to detect if you used a ;; destructive function but didn't use the result of the function. (result-not-used nil :type (or function null)) )) cmucl-21a/src/bootfiles/19c/boot-2005-11-2.lisp000066400000000000000000000001241260377556400205250ustar00rootroot00000000000000(in-package "C") (define-info-type typed-structure documentation (or string null)) cmucl-21a/src/bootfiles/19c/boot-2005-12-1-ppc.lisp000066400000000000000000000003341260377556400213100ustar00rootroot00000000000000;; This is a cross-compile script for ppc/darwin for moving the FDEFN ;; register. R10 is an integer arg register for calling C, so FDEFN ;; shouldn't be there. (load "target:tools/cross-scripts/cross-ppc-ppc-darwin") cmucl-21a/src/bootfiles/19c/boot-2005-12-2.lisp000066400000000000000000000001431260377556400205270ustar00rootroot00000000000000;; Needed by sparc to export the unix-sysinfo interface. #+sparc (load "target:code/exports.lisp") cmucl-21a/src/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp000066400000000000000000000161511260377556400230340ustar00rootroot00000000000000(in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "PPC" "OLD-PPC") (setf (c:backend-name c:*native-backend*) "OLD-PPC") (c::new-backend "PPC" ;; Features to add here '(:ppc :new-assembler :conservative-float-type :hash-new :random-mt19937 :darwin :bsd :cmu :cmu19 :cmu19c :relative-package-names ; Relative package names from Allegro :linkage-table :modular-arith :double-double ; Double-double float support :gencgc ; Generational gc ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :pentium :elf :mp :stack-checking :heap-overflow-check :cgc :long-float :new-random :small)) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "KERNEL") (eval-when (compile load eval) (c:defknown double-double-float-p (t) boolean (c:movable c:foldable c:flushable)) ) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant type-test-ordering '(fixnum single-float double-float integer #+long-float long-float double-double-float bignum complex ratio)) )) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant float-formats '(double-double-float long-float double-float single-float short-float)))) (in-package "LISP") (define-fop (fop-double-double-float 67) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((hi-lo (fast-read-u-integer 4)) (hi-hi (fast-read-s-integer 4)) (lo-lo (fast-read-u-integer 4)) (lo-hi (fast-read-s-integer 4))) (kernel::make-double-double-float (make-double-float hi-hi hi-lo) (make-double-float lo-hi lo-lo))) (done-with-fast-read-byte)))) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:ppc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/ppc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-BIT-VECTOR-TYPE OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-ppc::any-reg ht) (gethash 'ppc::any-reg ht))) ;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is ;; available in both the OLD-PPC and new PPC package. (I don't know ;; why this is needed, but it seems to be.) (let ((ht (c::backend-template-names c::*target-backend*))) (dolist (syms '((old-ppc::move-double-to-int-arg ppc::move-double-to-int-arg) (old-ppc::move-single-to-int-arg ppc::move-single-to-int-arg))) (destructuring-bind (old new) syms (setf (gethash old ht) (gethash new ht))))) cmucl-21a/src/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp000066400000000000000000000210641260377556400233610ustar00rootroot00000000000000;;;; This is the cross-compile script for adding the ;;;; double-double-float type for sparc. ;;;; ;;;; Use the standard src/tools/cross-build-world.sh script with this ;;;; cross-compile script to generate a double-double-float build. ;;;; Something like ;;;; ;;;; src/tools/cross-build-world.sh xtarget xcross <19c binary> ;;;; ;;;; Once that has been done, you still need to do a full set of ;;;; builds to get one with double-double-float integrated in. Use ;;;; the boot-2006-06-1.lisp bootstrap file for that. Something like: ;;;; ;;;; src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit" ;;;; (in-package :cl-user) ;;; Rename the SPARC package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") (c::new-backend "SPARC" ;; Features to add here '(:sparc :sparc-v9 ; For Ultrasparc processors :complex-fp-vops ; Some slightly faster FP vops on complex numbers :linkage-table :stack-checking ; Throw error if we run out of stack :heap-overflow-check ; Throw error if we run out of heap :gencgc ; Generational GC :relative-package-names ; Relative package names from Allegro :conservative-float-type :hash-new :random-mt19937 ; MT-19937 generator :cmu ; Announce this is CMUCL :cmu19 :cmu19c ; Current version identifier :modular-arith ; Modular arithmetic :double-double ; Add double-double-float support. ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 ;; Other architectures we aren't using. :x86 :x86-bootstrap :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type ;; Other OSes were not using :openbsd :freebsd :glibc2 :linux :pentium :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) ;; When compiling the compiler, vm:fixup-code-object and ;; vm:sanctify-for-execution are undefined. Import these to get rid ;; of that error. (import 'old-sparc::fixup-code-object) (import 'old-sparc::sanctify-for-execution) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "KERNEL") (eval-when (compile load eval) (c:defknown double-double-float-p (t) boolean (c:movable c:foldable c:flushable)) ) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant type-test-ordering '(fixnum single-float double-float integer #+long-float long-float double-double-float bignum complex ratio)) )) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant float-formats '(double-double-float long-float double-float single-float short-float)))) (in-package "LISP") (define-fop (fop-double-double-float 67) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((hi-lo (fast-read-u-integer 4)) (hi-hi (fast-read-s-integer 4)) (lo-lo (fast-read-u-integer 4)) (lo-hi (fast-read-s-integer 4))) (kernel::make-double-double-float (make-double-float hi-hi hi-lo) (make-double-float lo-hi lo-lo))) (done-with-fast-read-byte)))) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS OLD-SPARC:LOWTAG-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET OLD-SPARC:DOUBLE-FLOAT-DIGITS old-sparc:single-float-digits )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; Sometimes during cross-compile sparc::any-reg isn't defined during ;; cross-compile. ;; ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg ;; to the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) cmucl-21a/src/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp000066400000000000000000000144561260377556400227050ustar00rootroot00000000000000(in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86") (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here '(:x86 :i486 :pentium :stack-checking :heap-overflow-check :relative-package-names :mp :gencgc :conservative-float-type :hash-new :random-mt19937 :linux :glibc2 :glibc2.1 :cmu :cmu19 :cmu19c :double-double ; double-double-float ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :long-float :new-random :small)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "KERNEL") (eval-when (compile load eval) (c:defknown double-double-float-p (t) boolean (c:movable c:foldable c:flushable)) ) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant type-test-ordering '(fixnum single-float double-float integer #+long-float long-float double-double-float bignum complex ratio)) )) (eval-when (compile load eval) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant float-formats '(double-double-float long-float double-float single-float short-float)))) (in-package "LISP") (define-fop (fop-double-double-float 67) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((hi-lo (fast-read-u-integer 4)) (hi-hi (fast-read-s-integer 4)) (lo-lo (fast-read-u-integer 4)) (lo-hi (fast-read-s-integer 4))) (kernel::make-double-double-float (make-double-float hi-hi hi-lo) (make-double-float lo-hi lo-lo))) (done-with-fast-read-byte)))) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-BIT-VECTOR-TYPE OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET )) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'x86::any-reg ht))) cmucl-21a/src/bootfiles/19c/boot-2006-06-1.lisp000066400000000000000000000032271260377556400205400ustar00rootroot00000000000000;;;; Bootstrap file for doing a full build from a cross-compile for ;;;; double-double-float support. This needs to be done using the ;;;; build from the cross-compile for double-double-float. See ;;;; boot-2006-06-1-cross-dd-sparc.lisp for more info. (in-package :cl-user) (pushnew :double-double *features*) (setf lisp::*enable-package-locked-errors* nil) ;;; This is a hack. I need make-double-double-float, ;;; double-double-hi, double-double-lo, and %double-double-float to ;;; work. For some reason, the cross-compile makes these known ;;; functions be infinite loops, but if we compile them here and setf ;;; fdefinition we get workingness. (defun %foo (x y) (declare (double-float x y)) (kernel:%make-double-double-float x y)) (compile '%foo) (defun foo-hi (x) (declare (type kernel:double-double-float x)) (kernel:double-double-hi x)) (compile 'foo-hi) (defun foo-lo (x) (declare (type kernel:double-double-float x)) (kernel:double-double-lo x)) (compile 'foo-lo) (defun %coerce-foo (x) (if (typep x 'kernel:double-double-float) x (kernel:make-double-double-float (float x 1d0) 0d0))) (compile '%foo) (setf (fdefinition 'kernel::%make-double-double-float) #'%foo) (setf (fdefinition 'kernel::double-double-hi) #'foo-hi) (setf (fdefinition 'kernel::double-double-lo) #'foo-lo) (setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo) (in-package "KERNEL") (defun make-double-double-float (hi lo) ;; Make sure the parts make sense for a double-double (if (or (float-infinity-p hi) (float-nan-p hi)) (%make-double-double-float hi lo) (multiple-value-bind (s e) (c::two-sum hi lo) (%make-double-double-float s e)))) cmucl-21a/src/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp000066400000000000000000000207521260377556400230370ustar00rootroot00000000000000;;; ;;; Cross-compile script to add (simple-array double-double-float (*)). ;;; ;;; Use the standard cross-build-world.sh with this file to ;;; cross-compile. For this to work, you need a binary that already ;;; has double-double-float support, including reader support. (A ;;; build from the double-double-reader-branch will do nicely.) Then ;;; do a normal full build using the cross-compiled build to get a ;;; binary with support for 1D simple arrays of double-double-float. (in-package :cl-user) ;;; Rename the PPC package and backend so that new-backend does the ;;; right thing. (rename-package "PPC" "OLD-PPC") (setf (c:backend-name c:*native-backend*) "OLD-PPC") (c::new-backend "PPC" ;; Features to add here '(:ppc :new-assembler :conservative-float-type :hash-new :random-mt19937 :darwin :bsd :cmu :cmu19 :cmu19c :relative-package-names ; Relative package names from Allegro :linkage-table :modular-arith :double-double ; Double-double float support :gencgc ; Generational gc ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :pentium :elf :mp :stack-checking :heap-overflow-check :cgc :long-float :new-random :small)) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "C") (eval-when (compile load eval) (defknown simple-array-double-double-float-p (t) boolean (movable foldable flushable)) (defknown complex-double-double-float-p (t) boolean (movable foldable flushable)) (defknown simple-array-complex-double-double-float-p (t) boolean (movable foldable flushable)) ) (in-package "LISP") (define-fop (fop-double-double-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-double-float))) (read-n-bytes *fasl-file* result 0 (* length 4 4)) result)) (define-fop (fop-complex-double-double-float 89) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((real-hi-lo (fast-read-u-integer 4)) (real-hi-hi (fast-read-s-integer 4)) (real-lo-lo (fast-read-u-integer 4)) (real-lo-hi (fast-read-s-integer 4)) (re (kernel::make-double-double-float (make-double-float real-hi-hi real-hi-lo) (make-double-float real-lo-hi real-lo-lo))) (imag-hi-lo (fast-read-u-integer 4)) (imag-hi-hi (fast-read-s-integer 4)) (imag-lo-lo (fast-read-u-integer 4)) (imag-lo-hi (fast-read-s-integer 4)) (im (kernel::make-double-double-float (make-double-float imag-hi-hi imag-hi-lo) (make-double-float imag-lo-hi imag-lo-lo)))) (complex re im)) (done-with-fast-read-byte)))) (define-fop (fop-complex-double-double-float-vector 90) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-double-float)))) (read-n-bytes *fasl-file* result 0 (* length 4 8)) result)) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package "CL-USER") ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:ppc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/ppc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-BIT-VECTOR-TYPE OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET OLD-PPC:DOUBLE-FLOAT-EXPONENT-BYTE OLD-PPC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-PPC:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-PPC:SINGLE-FLOAT-EXPONENT-BYTE OLD-PPC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-PPC:SINGLE-FLOAT-SIGNIFICAND-BYTE )) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-ppc::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-ppc::lognot-mod32) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-ppc::any-reg ht) (gethash 'ppc::any-reg ht))) ;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is ;; available in both the OLD-PPC and new PPC package. (I don't know ;; why this is needed, but it seems to be.) (let ((ht (c::backend-template-names c::*target-backend*))) (dolist (syms '((old-ppc::move-double-to-int-arg ppc::move-double-to-int-arg) (old-ppc::move-single-to-int-arg ppc::move-single-to-int-arg))) (destructuring-bind (old new) syms (setf (gethash old ht) (gethash new ht))))) cmucl-21a/src/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp000066400000000000000000000234411260377556400233630ustar00rootroot00000000000000;;;; This is the cross-compile script for adding the (complex ;;;; double-double-float), (simple-array double-double-float (*)), and ;;;; (simple-array (complex double-double-float) (*)) types for sparc. ;;;; ;;;; Use the standard src/tools/cross-build-world.sh script with this ;;;; cross-compile script to generate a double-double-float build. ;;;; Something like ;;;; ;;;; src/tools/cross-build-world.sh xtarget xcross ;;;; ;;;; I think this has to be built using a version that has reader ;;;; support for double-double-float. I didn't try it any othe way. ;;;; ;;;; Once that has been done, you still need to do a full set of ;;;; builds to get these new types completely integrated in. Don't ;;;; need any special bootstrap files for this, so ;;;; ;;;; src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit" ;;;; (in-package :cl-user) ;;; Rename the SPARC package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC") (setf (c:backend-name c:*native-backend*) "OLD-SPARC") (c::new-backend "SPARC" ;; Features to add here '(:sparc :sparc-v9 ; For Ultrasparc processors :complex-fp-vops ; Some slightly faster FP vops on complex numbers :linkage-table :stack-checking ; Throw error if we run out of stack :heap-overflow-check ; Throw error if we run out of heap :gencgc ; Generational GC :relative-package-names ; Relative package names from Allegro :conservative-float-type :hash-new :random-mt19937 ; MT-19937 generator :cmu ; Announce this is CMUCL :cmu19 :cmu19c ; Current version identifier :modular-arith ; Modular arithmetic :double-double ; Add double-double-float support. ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 ;; Other architectures we aren't using. :x86 :x86-bootstrap :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type ;; Other OSes were not using :openbsd :freebsd :glibc2 :linux :pentium :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) ;; When compiling the compiler, vm:fixup-code-object and ;; vm:sanctify-for-execution are undefined. Import these to get rid ;; of that error. (import 'old-sparc::fixup-code-object) (import 'old-sparc::sanctify-for-execution) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "C") (pushnew :double-double *features*) (defknown simple-array-double-double-float-p (t) boolean (movable foldable flushable)) (defknown complex-double-double-float-p (t) boolean (movable foldable flushable)) (defknown simple-array-complex-double-double-float-p (t) boolean (movable foldable flushable)) (in-package "LISP") #+double-double (define-fop (fop-double-double-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-double-float))) (read-n-bytes *fasl-file* result 0 (* length 4 4)) result)) #+double-double (define-fop (fop-complex-double-double-float 89) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((real-hi-lo (fast-read-u-integer 4)) (real-hi-hi (fast-read-s-integer 4)) (real-lo-lo (fast-read-u-integer 4)) (real-lo-hi (fast-read-s-integer 4)) (re (kernel::make-double-double-float (make-double-float real-hi-hi real-hi-lo) (make-double-float real-lo-hi real-lo-lo))) (imag-hi-lo (fast-read-u-integer 4)) (imag-hi-hi (fast-read-s-integer 4)) (imag-lo-lo (fast-read-u-integer 4)) (imag-lo-hi (fast-read-s-integer 4)) (im (kernel::make-double-double-float (make-double-float imag-hi-hi imag-hi-lo) (make-double-float imag-lo-hi imag-lo-lo)))) (complex re im)) (done-with-fast-read-byte)))) #+double-double (define-fop (fop-complex-double-double-float-vector 90) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-double-float)))) (read-n-bytes *fasl-file* result 0 (* length 4 8)) result)) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS OLD-SPARC:LOWTAG-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE #+double-double OLD-SPARC:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET OLD-SPARC:DOUBLE-FLOAT-DIGITS old-sparc:single-float-digits OLD-SPARC:DOUBLE-FLOAT-EXPONENT-BYTE OLD-SPARC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-SPARC:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-SPARC:SINGLE-FLOAT-EXPONENT-BYTE OLD-SPARC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-SPARC:SINGLE-FLOAT-SIGNIFICAND-BYTE )) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-sparc::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-sparc::lognot-mod32) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; Sometimes during cross-compile sparc::any-reg isn't defined during ;; cross-compile. ;; ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg ;; to the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) cmucl-21a/src/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp000066400000000000000000000171741260377556400227060ustar00rootroot00000000000000;;; Cross-compile script for adding (complex double-double-float), ;;; (simple-array double-double-float (*)) and (simple-array (complex ;;; double-double-float) (*)). ;;; ;;; Use this to cross-compile from a version that supports ;;; double-double-float type with reader support. Once this is done, ;;; do a full rebuild to get a version with support for these new ;;; types. (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86") (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here '(:x86 :i486 :pentium :stack-checking :heap-overflow-check :relative-package-names :mp :gencgc :conservative-float-type :hash-new :random-mt19937 :linux :glibc2 :glibc2.1 :cmu :cmu19 :cmu19c :double-double ; double-double-float ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :long-float :new-random :small)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile double-double changes. (in-package "C") (eval-when (compile load eval) (defknown simple-array-double-double-float-p (t) boolean (movable foldable flushable)) (defknown double-double-float-p (t) boolean (movable foldable flushable)) (defknown complex-double-double-float-p (t) boolean (movable foldable flushable)) (defknown simple-array-complex-double-double-float-p (t) boolean (movable foldable flushable)) ) (in-package "LISP") (define-fop (fop-double-double-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-double-float))) (read-n-bytes *fasl-file* result 0 (* length 4 4)) result)) (define-fop (fop-complex-double-double-float 89) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((real-hi-lo (fast-read-u-integer 4)) (real-hi-hi (fast-read-s-integer 4)) (real-lo-lo (fast-read-u-integer 4)) (real-lo-hi (fast-read-s-integer 4)) (re (kernel::make-double-double-float (make-double-float real-hi-hi real-hi-lo) (make-double-float real-lo-hi real-lo-lo))) (imag-hi-lo (fast-read-u-integer 4)) (imag-hi-hi (fast-read-s-integer 4)) (imag-lo-lo (fast-read-u-integer 4)) (imag-lo-hi (fast-read-s-integer 4)) (im (kernel::make-double-double-float (make-double-float imag-hi-hi imag-hi-lo) (make-double-float imag-lo-hi imag-lo-lo)))) (complex re im)) (done-with-fast-read-byte)))) (define-fop (fop-complex-double-double-float-vector 90) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-double-float)))) (read-n-bytes *fasl-file* result 0 (* length 4 8)) result)) ;; End changes for double-double ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm))))) syms)))) (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-BIT-VECTOR-TYPE OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET OLD-X86:DOUBLE-FLOAT-EXPONENT-BYTE OLD-X86:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-X86:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-X86:SINGLE-FLOAT-EXPONENT-BYTE OLD-X86:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-X86:SINGLE-FLOAT-SIGNIFICAND-BYTE )) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-x86::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-x86::lognot-mod32) (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'x86::any-reg ht))) cmucl-21a/src/bootfiles/19c/boot-2006-06-3.lisp000066400000000000000000000002521260377556400205350ustar00rootroot00000000000000;; Get rid of LISP::SOCKET-ERROR. It's really EXT:SOCKET-ERROR. (in-package "LISP") (eval-when (compile load eval) (without-package-locks (unintern 'socket-error)) ) cmucl-21a/src/bootfiles/19c/boot-2006-08-1-cross.lisp000066400000000000000000000006051260377556400216660ustar00rootroot00000000000000;; This simple file is used to bootstrap the weak hash table changes. ;; The cross-compile is only needed because we want to add four new ;; static symbols so the C code can access them. #+ppc (load "target:tools/cross-scripts/cross-ppc-ppc-darwin.lisp") #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc.lisp") #+x86 (load "target:tools/cross-scripts/cross-x86-x86.lisp") cmucl-21a/src/bootfiles/19c/boot-2006-11-1-cross-ppc.lisp000066400000000000000000000004771260377556400224470ustar00rootroot00000000000000;; This simple file is used to bootstrap the changes that remove the ;; constraint on the read-only space being in low memory. This also ;; means we don't need those linker hacks and adjuster hacks. ;; Standard cross-compile script is good enough. #+ppc (load "target:tools/cross-scripts/cross-ppc-ppc-darwin.lisp") cmucl-21a/src/bootfiles/19d/000077500000000000000000000000001260377556400157335ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19d/boot-19e.lisp000066400000000000000000000035621260377556400201710ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19e. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; (setf (symbol-value 'byte-fasl-file-version) #x19e) (setf (backend-fasl-file-version *target-backend*) #x19e) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/19d/boot-2007-05-1-ppc.lisp000066400000000000000000000020301260377556400213100ustar00rootroot00000000000000;;; Bootstrap file for fused multiply vops for ppc. (in-package "VM") #+ppc (progn (defknown (vm::fused-multiply-subtract vm::fused-multiply-add) (double-float double-float double-float) double-float (movable flushable)) (export '(fused-multiply-subtract fused-multiply-add)) (define-vop (fused-multiply-subtract/double) (:args (x :scs (double-reg)) (y :scs (double-reg)) (z :scs (double-reg))) (:results (r :scs (double-reg))) (:arg-types double-float double-float double-float) (:result-types double-float) (:translate vm::fused-multiply-subtract) (:policy :fast-safe) (:generator 1 ;; r = x*y - z (inst fmsub r x y z))) (define-vop (fused-multiply-add/double) (:args (x :scs (double-reg)) (y :scs (double-reg)) (z :scs (double-reg))) (:results (r :scs (double-reg))) (:arg-types double-float double-float double-float) (:result-types double-float) (:translate vm::fused-multiply-add) (:policy :fast-safe) (:generator 1 ;; r = x*y + z (inst fmadd r x y z))) )cmucl-21a/src/bootfiles/19d/boot-2007-11-1.lisp000066400000000000000000000005361260377556400205360ustar00rootroot00000000000000;; Bootstrap file for bref cleanup (in-package "EXTENSIONS") (without-package-locks (dolist (symbol '(bref buffer-sap endian-swap-value vector-elt-width)) (unintern symbol))) (in-package "KERNEL") (without-package-locks (export 'simple-stream-buffer) (deftype simple-stream-buffer () '(or sys:system-area-pointer (simple-unboxed-array (*)))) ) cmucl-21a/src/bootfiles/19d/boot-2007-11-2.lisp000066400000000000000000000013421260377556400205330ustar00rootroot00000000000000;;; Bootstrap file for removing the FLOAT-ACCURACY stuff. ;;; ;;; For x86, I think you need to do a cross-compile. Use this file as ;;; the cross-compile script. For other architectures, I don't think ;;; you need to do a cross-compile. Just a normal build with this as ;;; the bootstrap file will work. #+x86 (load "target:bootfiles/19d/boot-2007-11-1") (in-package :c) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant policy-parameter-slots '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety) (cspeed . cookie-cspeed) (brevity . cookie-brevity) (debug . cookie-debug)))) #+x86 (load "target:tools/cross-scripts/cross-x86-x86") cmucl-21a/src/bootfiles/19d/boot-2007-12-1.lisp000066400000000000000000000004311260377556400205310ustar00rootroot00000000000000(in-package "VM") (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant max-bits (1- (ash 1 vm:word-bits)) "The maximum number of bits that can be delt with during a single call.")) cmucl-21a/src/bootfiles/19e/000077500000000000000000000000001260377556400157345ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19e/boot-19f.lisp000066400000000000000000000035621260377556400201730ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 19e. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; (setf (symbol-value 'byte-fasl-file-version) #x19f) (setf (backend-fasl-file-version *target-backend*) #x19f) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/19e/boot-2008-04-1.lisp000066400000000000000000000010141260377556400205320ustar00rootroot00000000000000;; Bootstrap to change the vops to use 32-bit registers for characters. ;; A basic cross-compile works too. #+x86 (in-package :x86) #+x86 (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant byte-sc-names '(byte-reg)) (defconstant dword-sc-names '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack signed-stack unsigned-stack sap-stack single-stack constant base-char-reg base-char-stack)))cmucl-21a/src/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp000066400000000000000000000346671260377556400244620ustar00rootroot00000000000000;;; Common part for cross-compiling 16-bit strings for Unicode. ;;; This part is independent of the architecture. (load "target:bootfiles/19f/boot-2009-07") (pushnew :unicode *features*) (pushnew :unicode-bootstrap *features*) (in-package "C") (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) ;; Update so we create the correct size of arrays for characters. (defconstant array-info '((base-char #\NULL 16 old-vm:simple-string-type) (single-float 0.0f0 32 old-vm:simple-array-single-float-type) (double-float 0.0d0 64 old-vm:simple-array-double-float-type) #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128 old-vm:simple-array-long-float-type) #+double-double (double-double-float 0w0 128 old-vm::simple-array-double-double-float-type) (bit 0 1 old-vm:simple-bit-vector-type) ((unsigned-byte 2) 0 2 old-vm:simple-array-unsigned-byte-2-type) ((unsigned-byte 4) 0 4 old-vm:simple-array-unsigned-byte-4-type) ((unsigned-byte 8) 0 8 old-vm:simple-array-unsigned-byte-8-type) ((unsigned-byte 16) 0 16 old-vm:simple-array-unsigned-byte-16-type) ((unsigned-byte 32) 0 32 old-vm:simple-array-unsigned-byte-32-type) ((signed-byte 8) 0 8 old-vm:simple-array-signed-byte-8-type) ((signed-byte 16) 0 16 old-vm:simple-array-signed-byte-16-type) ((signed-byte 30) 0 32 old-vm:simple-array-signed-byte-30-type) ((signed-byte 32) 0 32 old-vm:simple-array-signed-byte-32-type) ((complex single-float) #C(0.0f0 0.0f0) 64 old-vm:simple-array-complex-single-float-type) ((complex double-float) #C(0.0d0 0.0d0) 128 old-vm:simple-array-complex-double-float-type) #+long-float ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256 old-vm:simple-array-complex-long-float-type) #+double-double ((complex double-double-float) #C(0.0w0 0.0w0) 256 old-vm::simple-array-complex-double-double-float-type) (t 0 32 old-vm:simple-vector-type))) ) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (fd-stream (:print-function %print-fd-stream) (:constructor %make-fd-stream) (:include file-stream (misc #'fd-stream-misc-routine))) (name nil) ; The name of this stream (file nil) ; The file this stream is for ;; ;; The backup file namestring for the old file, for :if-exists :rename or ;; :rename-and-delete. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete ;; ;;; Number of bytes per element. (element-size 1 :type index) (element-type 'base-char) ; The type of element being transfered. (fd -1 :type fixnum) ; The file descriptor ;; ;; Controls when the output buffer is flushed. (buffering :full :type (member :full :line :none)) ;; ;; Character position if known. (char-pos nil :type (or index null)) ;; ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) ;; ;; The input buffer. (unread nil) (ibuf-sap nil :type (or system-area-pointer null)) (ibuf-length nil :type (or index null)) (ibuf-head 0 :type index) (ibuf-tail 0 :type index) ;; The output buffer. (obuf-sap nil :type (or system-area-pointer null)) (obuf-length nil :type (or index null)) (obuf-tail 0 :type index) ;; Output flushed, but not written due to non-blocking io. (output-later nil) (handler nil) ;; ;; Timeout specified for this stream, or NIL if none. (timeout nil :type (or index null)) ;; ;; Pathname of the file this stream is opened to (returned by PATHNAME.) (pathname nil :type (or pathname null)) ;; ;; External formats ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot ;; so initialize to NIL and fix it in SET-ROUTINES #+unicode (external-format nil :type (or null keyword cons)) #+unicode (oc-state nil) #+unicode (co-state nil) #+unicode (last-char-read-size 0 :type index))) (defun %print-fd-stream (fd-stream stream depth) (declare (ignore depth) (stream stream)) (format stream "#" (fd-stream-name fd-stream))) ;; Dump a character of a string to a fasl file in the byte correct ;; order. (defun dump-string-char (code file) ;; Do we want *native-backend* or *target-backend*? Use ;; *native-backend* because we're assuming we're cross-compiling ;; from the same arch as the desired arch. (ecase (c::backend-byte-order c::*native-backend*) (:little-endian (dump-byte (ldb (byte 8 0) code) file) (dump-byte (ldb (byte 8 8) code) file)) (:big-endian (dump-byte (ldb (byte 8 8) code) file) (dump-byte (ldb (byte 8 0) code) file)))) ;; Dump a string one character at a time because in the ;; cross-compiler, we're still using 8-bit strings, but want 16-bit ;; strings in the resulting fasl file. (defun dump-simple-string (s file) (declare (type simple-base-string s)) (let ((length (length s))) (dump-fop* length lisp::fop-small-string lisp::fop-string file) (dotimes (k length) (dump-string-char (char-code (aref s k)) file))) (undefined-value)) ;; Like dump-simple-string (defun dump-symbol (s file) (let* ((pname (symbol-name s)) (pname-length (length pname)) (pkg (symbol-package s))) (cond ((null pkg) (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save lisp::fop-uninterned-symbol-save file)) ;; Why do we do this? It causes weird things to happen if ;; you're in, say, the KERNEL package when you compile-file ;; something and load the fasl back in when you're in a ;; different package. #-(and) ((eq pkg *package*) (dump-fop* pname-length lisp::fop-small-symbol-save lisp::fop-symbol-save file)) ((eq pkg ext:*lisp-package*) (dump-fop* pname-length lisp::fop-lisp-small-symbol-save lisp::fop-lisp-symbol-save file)) ((eq pkg ext:*keyword-package*) (dump-fop* pname-length lisp::fop-keyword-small-symbol-save lisp::fop-keyword-symbol-save file)) ((< pname-length 256) (dump-fop* (dump-package pkg file) lisp::fop-small-symbol-in-byte-package-save lisp::fop-small-symbol-in-package-save file) (dump-byte pname-length file)) (t (dump-fop* (dump-package pkg file) lisp::fop-symbol-in-byte-package-save lisp::fop-symbol-in-package-save file) (dump-unsigned-32 pname-length file))) (dotimes (k pname-length) (dump-string-char (char-code (aref pname k)) file)) (unless *cold-load-dump* (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file))) (incf (fasl-file-table-free file))) (undefined-value)) ;; We always dump characters in little endian order, which seems to be ;; the way most fops are done. (defun dump-character (ch file) (dump-fop 'lisp::fop-short-character file) (let ((code (char-code ch))) (dump-byte (ldb (byte 8 0) code) file) (dump-byte (ldb (byte 8 8) code) file))) (defun dump-fixups (fixups file) (declare (list fixups) (type fasl-file file)) (dolist (info fixups) (let* ((kind (first info)) (fixup (second info)) (name (fixup-name fixup)) (flavor (fixup-flavor fixup)) (offset (third info))) (dump-fop 'lisp::fop-normal-load file) (let ((*cold-load-dump* t)) (dump-object kind file)) (dump-fop 'lisp::fop-maybe-cold-load file) (ecase flavor (:assembly-routine (assert (symbolp name)) (dump-fop 'lisp::fop-normal-load file) (let ((*cold-load-dump* t)) (dump-object name file)) (dump-fop 'lisp::fop-maybe-cold-load file) (dump-fop 'lisp::fop-assembler-fixup file)) ((:foreign :foreign-data) (assert (stringp name)) (if (eq flavor :foreign) (dump-fop 'lisp::fop-foreign-fixup file) (dump-fop 'lisp::fop-foreign-data-fixup file)) (let ((len (length name))) (assert (< len 256)) (dump-byte len file) (dotimes (i len) (dump-string-char (char-code (schar name i)) file)))) (:code-object (dump-fop 'lisp::fop-code-object-fixup file))) (dump-unsigned-32 offset file))) (undefined-value)) (in-package "LISP") ;; See print.lisp. (defconstant othercase-attribute (ash 1 9)) (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (defconstant attribute-names `((number . number-attribute) (lowercase . lowercase-attribute) (uppercase . uppercase-attribute) (letter . letter-attribute) (sign . sign-attribute) (extension . extension-attribute) (dot . dot-attribute) (slash . slash-attribute) (other . other-attribute) (funny . funny-attribute) (othercase . othercase-attribute)))) ;; Opposite of dump-string-char. (defmacro load-string-char () (ecase (c::backend-byte-order c::*native-backend*) (:little-endian `(code-char (+ (read-arg 1) (ash (read-arg 1) 8)))) (:big-endian `(code-char (+ (ash (read-arg 1) 8) (read-arg 1)))))) ;; Needed to read in 16-bit strings. (clone-fop (fop-string 37) (fop-small-string 38) (let* ((arg (clone-arg)) (res (make-string arg))) (dotimes (k arg) (setf (aref res k) (load-string-char))) res)) ;; Read in characters. They're always dumped in little-endian order. (define-fop (fop-short-character 69) (code-char (+ (read-arg 1) (ash (read-arg 1) 8)))) ;; Needed to read in 16-bit strings to create the symbols. (macrolet ((frob (name code name-size package) (let ((n-package (gensym "PACKAGE-")) (n-size (gensym "SIZE-")) (n-buffer (gensym "BUFFER-")) (k (gensym "IDX-"))) `(define-fop (,name ,code) (prepare-for-fast-read-byte *fasl-file* (let ((,n-package ,package) (,n-size (fast-read-u-integer ,name-size))) (when (> ,n-size *load-symbol-buffer-size*) (setq *load-symbol-buffer* (make-string (setq *load-symbol-buffer-size* (* ,n-size 2))))) (done-with-fast-read-byte) (let ((,n-buffer *load-symbol-buffer*)) (dotimes (,k ,n-size) (setf (aref ,n-buffer ,k) (load-string-char))) (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) (frob fop-symbol-save 6 4 *package*) (frob fop-small-symbol-save 7 1 *package*) (frob fop-lisp-symbol-save 75 4 *lisp-package*) (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) (frob fop-keyword-symbol-save 77 4 *keyword-package*) (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) (frob fop-symbol-in-package-save 8 4 (svref *current-fop-table* (fast-read-u-integer 4))) (frob fop-small-symbol-in-package-save 9 1 (svref *current-fop-table* (fast-read-u-integer 4))) (frob fop-symbol-in-byte-package-save 10 4 (svref *current-fop-table* (fast-read-u-integer 1))) (frob fop-small-symbol-in-byte-package-save 11 1 (svref *current-fop-table* (fast-read-u-integer 1)))) (clone-fop (fop-uninterned-symbol-save 12) (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) (res (make-string arg))) (dotimes (k arg) (setf (aref res k) (load-string-char))) (push-table (make-symbol res)))) (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) (dotimes (k len) (setf (aref sym k) (load-string-char))) (old-vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-aux sym :code) kind) code-object)) (define-fop (fop-foreign-data-fixup 150) (let* ((kind (pop-stack)) (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) (dotimes (k len) (setf (aref sym k) (load-string-char))) (old-vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-aux sym :data) kind) code-object)) ;; Kill the any deftransforms. They get in the way because they ;; assume 8-bit strings. (in-package "C") (dolist (f '(concatenate subseq replace copy-seq)) (setf (c::function-info-transforms (c::function-info-or-lose f)) nil)) (in-package "C-CALL") (def-alien-type-method (c-string :deport-gen) (type value) (declare (ignore type)) (let ((s (gensym "C-STRING-")) (len (gensym "LEN-")) (k (gensym "IDX-"))) `(etypecase ,value (null (int-sap 0)) ((alien (* char)) (alien-sap ,value)) (simple-base-string (let* ((,len (length ,value)) (,s (make-array (1+ ,len) :element-type '(unsigned-byte 8)))) (dotimes (,k ,len) (setf (aref ,s ,k) (logand #xff (char-code (aref ,value ,k))))) (setf (aref ,s ,len) 0) (vector-sap ,s)))))) ;;; Might as well update the FASL file version too, since we have to ;;; do a cross-compile anyway, and the Unicode fasl's aren't even ;;; close to being compatible with previous versions. (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; (setf (symbol-value 'byte-fasl-file-version) #x20a) (setf (backend-fasl-file-version *target-backend*) #x20a) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/19e/boot-2008-05-cross-unicode-ppc.lisp000066400000000000000000000153711260377556400237430ustar00rootroot00000000000000;;; Cross-compile script to add 16-bit strings for Unicode support. ;;; Use as the cross-compile script for cross-build-world.sh. (in-package :cl-user) ;;; Rename the PPC package and backend so that new-backend does the ;;; right thing. (rename-package "PPC" "OLD-PPC" '("OLD-VM")) (setf (c:backend-name c:*native-backend*) "OLD-PPC") (c::new-backend "PPC" ;; Features to add here '(:ppc :new-assembler :conservative-float-type :hash-new :random-mt19937 :darwin :bsd :cmu :cmu19 :cmu19e :relative-package-names ; Relative package names from Allegro :linkage-table :modular-arith ; Modular arithmetic :double-double ; Double-double floats :gencgc ; Generational GC ) ;; Features to remove from current *features* here '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro :propagate-fun-type :propagate-float-type :constrain-float-type :openbsd :freebsd :glibc2 :linux :pentium :elf :mp :stack-checking :heap-overflow-check :cgc :long-float :new-random :small)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile unicode changes. (load "target:bootfiles/19e/boot-2008-05-cross-unicode-common.lisp") ;; End changes for unicode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:ppc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/ppc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-PPC:SIMPLE-BIT-VECTOR-TYPE OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET OLD-PPC:DOUBLE-FLOAT-EXPONENT-BYTE OLD-PPC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-PPC:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-PPC:SINGLE-FLOAT-EXPONENT-BYTE OLD-PPC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-PPC:SINGLE-FLOAT-SIGNIFICAND-BYTE )) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-ppc::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-ppc::lognot-mod32) ;; Fused multiply hack. Don't know why this is needed for a cross-compile (setf (fdefinition 'vm::fused-multiply-add) #'old-ppc::fused-multiply-add) (setf (fdefinition 'vm::fused-multiply-subtract) #'old-ppc::fused-multiply-subtract) ;; end (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) (concatenate 'string "_" name)) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-ppc::any-reg ht) (gethash 'ppc::any-reg ht))) ;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is ;; available in both the OLD-PPC and new PPC package. (I don't know ;; why this is needed, but it seems to be.) (let ((ht (c::backend-template-names c::*target-backend*))) (dolist (syms '((old-ppc::move-double-to-int-arg ppc::move-double-to-int-arg) (old-ppc::move-single-to-int-arg ppc::move-single-to-int-arg))) (destructuring-bind (old new) syms (setf (gethash old ht) (gethash new ht))))) cmucl-21a/src/bootfiles/19e/boot-2008-05-cross-unicode-sparc.lisp000066400000000000000000000172311260377556400242660ustar00rootroot00000000000000;;; Cross-compile script to add 16-bit strings for Unicode support. ;;; Use as the cross-compile script for cross-build-world.sh. (in-package :cl-user) ;;; Rename the SPARC package and backend so that new-backend does the ;;; right thing. (rename-package "SPARC" "OLD-SPARC" '("OLD-VM")) (setf (c:backend-name c:*native-backend*) "OLD-SPARC") (c::new-backend "SPARC" ;; Features to add here '(:sparc :sparc-v9 ; For Ultrasparc processors :complex-fp-vops ; Some slightly faster FP vops on complex numbers :linkage-table :stack-checking ; Throw error if we run out of stack :heap-overflow-check ; Throw error if we run out of ; heap (This requires gencgc!) :gencgc ; Generational GC :relative-package-names ; Relative package names from Allegro :conservative-float-type :hash-new :random-mt19937 ; MT-19937 generator :cmu ; Announce this is CMUCL :cmu19 :cmu19e ; Current version identifier :modular-arith ; Modular arithmetic :double-double ; Double-double float support :unicode ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 ;; Other architectures we aren't using. :x86 :x86-bootstrap :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type ;; Other OSes were not using :openbsd :freebsd :glibc2 :linux :pentium :long-float :new-random :small)) ;;; May need to add some symbols to *features* and ;;; sys::*runtime-features* as well. This might be needed even if we ;;; have those listed above, because of the code checks for things in ;;; *features* and not in the backend-features.. So do that here. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile unicode changes. (load "target:bootfiles/19e/boot-2008-05-cross-unicode-common.lisp") ;; End changes for unicode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) ;; When compiling the compiler, vm:fixup-code-object and ;; vm:sanctify-for-execution are undefined. Import these to get rid ;; of that error. (import 'old-sparc::fixup-code-object) (import 'old-sparc::sanctify-for-execution) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:sparc/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/sparc/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (load "vm:system") (load "vm:char") (load "vm:float") (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS OLD-SPARC:CHAR-BITS OLD-SPARC:LOWTAG-BITS #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET OLD-SPARC:DOUBLE-FLOAT-DIGITS old-sparc:single-float-digits OLD-SPARC:DOUBLE-FLOAT-EXPONENT-BYTE OLD-SPARC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-SPARC:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-SPARC:SINGLE-FLOAT-EXPONENT-BYTE OLD-SPARC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-SPARC:SINGLE-FLOAT-SIGNIFICAND-BYTE ) #+double-double (frob OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE OLD-SPARC:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE) ) ;; Modular arith hacks. When cross-compiling, the compiler wants to ;; constant-fold some stuff, and it needs the following functions to ;; do so. This just gets rid of the hundreds of errors that happen. (setf (fdefinition 'vm::ash-left-mod32) #'old-sparc::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-sparc::lognot-mod32) ;; End modular arith hacks (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; Sometimes during cross-compile sparc::any-reg isn't defined during ;; cross-compile. ;; ;; hack, hack, hack: Make old-sparc::any-reg the same as ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg ;; to the hash table with the same value as sparc::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-sparc::any-reg ht) (gethash 'sparc::any-reg ht))) cmucl-21a/src/bootfiles/19e/boot-2008-05-cross-unicode-x86.lisp000066400000000000000000000141001260377556400235730ustar00rootroot00000000000000;;; Cross-compile script to add 16-bit strings for Unicode support. ;;; Use as the cross-compile script for cross-build-world.sh. (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86" '("OLD-VM")) (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here '(:x86 :i486 :pentium :stack-checking :heap-overflow-check :relative-package-names :mp :gencgc :conservative-float-type :hash-new :random-mt19937 :cmu :cmu19 :cmu19e :double-double :unicode ) ;; Features to remove from current *features* here '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Things needed to cross-compile unicode changes. (load "target:bootfiles/19e/boot-2008-05-cross-unicode-common.lisp") ;; Kill the any deftransforms (in-package "C") (dolist (f '(concatenate subseq replace copy-seq)) (setf (c::function-info-transforms (c::function-info-or-lose f)) nil)) ;; End changes for unicode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :cl-user) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (when (target-featurep :sse2) (load "vm:sse2-sap")) (load "vm:system") (load "vm:char") (if (target-featurep :sse2) (load "vm:float-sse2") (load "vm:float")) (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (if (target-featurep :sse2) (load "vm:sse2-c-call") (load "vm:x87-c-call")) (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") ;; These need to be loaded before array because array wants to use ;; some vops as templates. (load (if (target-featurep :sse2) "vm:sse2-array" "vm:x87-array")) (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-X86:SIMPLE-BIT-VECTOR-TYPE OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET OLD-X86:DOUBLE-FLOAT-EXPONENT-BYTE OLD-X86:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-X86:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-X86:SINGLE-FLOAT-EXPONENT-BYTE OLD-X86:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-X86:SINGLE-FLOAT-SIGNIFICAND-BYTE ) #+double-double (frob OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE OLD-X86:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-x86::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-x86::lognot-mod32) ;; End arith hacks (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-x86::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-x86::any-reg ht) (gethash 'x86::any-reg ht))) cmucl-21a/src/bootfiles/19e/boot-2008-05-no-unicode.lisp000066400000000000000000000005251260377556400224410ustar00rootroot00000000000000;; Bootstrap file to build the code without unicode. This is needed ;; because some new constants were added. (in-package "VM") (defconstant char-bits #-unicode 8 #+unicode 16 "Number of bits needed to represent a character") (defconstant char-bytes (truncate char-bits byte-bits) "Number of bytes needed to represent a character") cmucl-21a/src/bootfiles/19e/boot-2008-06-1.lisp000066400000000000000000000016411260377556400205420ustar00rootroot00000000000000;; Bootstrap new external-format structure. ;; ;; Just needed so we don't have to answer a cerror with clobber-it ;; when compiling pcl. (in-package "STREAM") (ext:without-package-locks (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (external-format (:conc-name ef-) (:print-function %print-external-format) (:constructor make-external-format (name composingp &optional slots slotd octets-to-code code-to-octets))) (name (ext:required-argument) :type (or keyword cons) :read-only t) (composingp (ext:required-argument) :type boolean :read-only t) (slots #() :type simple-vector :read-only t) (slotd nil :type list :read-only t) (octets-to-code #'%efni :type function :read-only t) (code-to-octets #'%efni :type function :read-only t) (cache (make-array +ef-max+ :initial-element nil))) ))cmucl-21a/src/bootfiles/19e/boot-2008-09-sse2.lisp000066400000000000000000000144111260377556400212600ustar00rootroot00000000000000;; Bootstrap file for cross-compiling SSE2 support for x86. (in-package :cl-user) ;;; Rename the X86 package and backend so that new-backend does the ;;; right thing. (rename-package "X86" "OLD-X86" '("OLD-VM")) (setf (c:backend-name c:*native-backend*) "OLD-X86") (c::new-backend "X86" ;; Features to add here. These are just examples. You may not ;; need to list anything here. We list them here anyway as a ;; record of typical features for all x86 ports. '(:x86 :i486 :pentium :stack-checking ; Catches stack overflow :heap-overflow-check ; Catches heap overflows :relative-package-names ; relative package names :mp ; multiprocessing :gencgc ; Generational GC :conservative-float-type :hash-new :random-mt19937 :cmu :cmu19 :cmu19e ; Version features :double-double ; double-double float support :sse2 ; SSE2 support :complex-fp-vops ; VOPs for complex arithmetic ) ;; Features to remove from current *features* here. Normally don't ;; need to list anything here unless you are trying to remove a ;; feature. '(:x86-bootstrap ;; :alpha :osf1 :mips :propagate-fun-type :propagate-float-type :constrain-float-type ;; :openbsd :freebsd :glibc2 :linux :long-float :new-random :small)) ;;; Compile the new backend. (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) (pushnew :sse2 *features*) (pushnew :complex-fp-vops *features*) (load "target:tools/comcom") ;;; Load the new backend. (setf (search-list "c:") '("target:compiler/")) (setf (search-list "vm:") '("c:x86/" "c:generic/")) (setf (search-list "assem:") '("target:assembly/" "target:assembly/x86/")) ;; Load the backend of the compiler. ;; Why do it explicitly this way? Why not use loadbackend.lisp? (in-package "C") (load "vm:vm-macs") (load "vm:parms") (load "vm:objdef") (load "vm:interr") (load "assem:support") (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") (load "target:compiler/saptran") (load "vm:macros") (load "vm:utils") (load "vm:vm") (load "vm:insts") (load "vm:primtype") (load "vm:move") (load "vm:sap") (when (target-featurep :sse2) (load "vm:sse2-sap")) (load "vm:system") (load "vm:char") (if (target-featurep :sse2) (load "vm:float-sse2") (load "vm:float")) (load "vm:memory") (load "vm:static-fn") (load "vm:arith") (load "vm:cell") (load "vm:subprim") (load "vm:debug") (load "vm:c-call") (when (target-featurep :sse2) (load "vm:sse2-c-call")) (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") ;; These need to be loaded before array because array wants to use ;; some vops as templates. (load (if (target-featurep :sse2) "vm:sse2-array" "vm:x87-array")) (load "vm:array") (load "vm:pred") (load "vm:type-vops") (load "assem:assem-rtns") (load "assem:array") (load "assem:arith") (load "assem:alloc") (load "c:pseudo-vops") (check-move-function-consistency) (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. (setf *features* (remove :building-cross-compiler *features*)) ;;; Info environment hacks. (macrolet ((frob (&rest syms) `(progn ,@(mapcar #'(lambda (sym) `(defconstant ,sym (symbol-value (find-symbol ,(symbol-name sym) :vm)))) syms)))) (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE OLD-VM:SIMPLE-BIT-VECTOR-TYPE OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE ) #+double-double (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)) ;; Modular arith hacks (setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32) (setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32) ;; End arith hacks (let ((function (symbol-function 'kernel:error-number-or-lose))) (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) (setf (symbol-function 'kernel:error-number-or-lose) function) (setf (info function kind 'kernel:error-number-or-lose) :function) (setf (info function where-from 'kernel:error-number-or-lose) :defined))) (defun fix-class (name) (let* ((new-value (find-class name)) (new-layout (kernel::%class-layout new-value)) (new-cell (kernel::find-class-cell name)) (*info-environment* (c:backend-info-environment c:*target-backend*))) (remhash name kernel::*forward-referenced-layouts*) (kernel::%note-type-defined name) (setf (info type kind name) :instance) (setf (info type class name) new-cell) (setf (info type compiler-layout name) new-layout) new-value)) (fix-class 'c::vop-parse) (fix-class 'c::operand-parse) #+random-mt19937 (declaim (notinline kernel:random-chunk)) (setf c:*backend* c:*target-backend*) ;;; Extern-alien-name for the new backend. (in-package :vm) (defun extern-alien-name (name) (declare (type simple-string name)) name) (export 'extern-alien-name) (export 'fixup-code-object) (export 'sanctify-for-execution) (in-package :cl-user) ;;; Don't load compiler parts from the target compilation (defparameter *load-stuff* nil) ;; hack, hack, hack: Make old-vm::any-reg the same as ;; x86::any-reg as an SC. Do this by adding old-vm::any-reg ;; to the hash table with the same value as x86::any-reg. (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-vm::any-reg ht) (gethash 'vm::any-reg ht))) cmucl-21a/src/bootfiles/19e/boot-2008-12.lisp000066400000000000000000000002021260377556400203710ustar00rootroot00000000000000;; Re-enable this on sparc. It makes the simple FFT butterfly 2.5 ;; times faster. #+sparc (pushnew :complex-fp-vops *features*) cmucl-21a/src/bootfiles/19e/boot-2009-01-1.lisp000066400000000000000000000010731260377556400205350ustar00rootroot00000000000000;; Bootstrap for x86 to change the location of the floating-point ;; fields. The fields must now match the definitions for the SSE2 ;; MXCSR register, even for x87. ;; ;; (Really only needed if we're not compiling for sse2.) (in-package "VM") #+(and x86 (not sse2)) (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant float-rounding-mode (byte 2 13)) (defconstant float-sticky-bits (byte 6 0)) (defconstant float-traps-byte (byte 6 7)) (defconstant float-exceptions-byte (byte 6 0)) ) cmucl-21a/src/bootfiles/19f/000077500000000000000000000000001260377556400157355ustar00rootroot00000000000000cmucl-21a/src/bootfiles/19f/boot-2009-03-cross-unicode-ppc.lisp000066400000000000000000000000751260377556400237360ustar00rootroot00000000000000(load "target:bootfiles/19e/boot-2008-05-cross-unicode-ppc") cmucl-21a/src/bootfiles/19f/boot-2009-03-cross-unicode-sparc.lisp000066400000000000000000000000771260377556400242660ustar00rootroot00000000000000(load "target:bootfiles/19e/boot-2008-05-cross-unicode-sparc") cmucl-21a/src/bootfiles/19f/boot-2009-03-cross-unicode-x86.lisp000066400000000000000000000000751260377556400236010ustar00rootroot00000000000000(load "target:bootfiles/19e/boot-2008-05-cross-unicode-x86") cmucl-21a/src/bootfiles/19f/boot-2009-03-unicode-char.lisp000066400000000000000000000002571260377556400227440ustar00rootroot00000000000000(in-package "LISP") ;; Not needed anymore with the Paul's new *unicode-data* structures. #| ;; Rebuild the *unicode-data* with the correct stuff. (rebuild-unicode-data) |# cmucl-21a/src/bootfiles/19f/boot-2009-05-no-unicode.lisp000066400000000000000000000001751260377556400224440ustar00rootroot00000000000000;; Use this to build the non-unicode version from the unicode sources. (load "target:bootfiles/19e/boot-2008-05-no-unicode") cmucl-21a/src/bootfiles/19f/boot-2009-07.lisp000066400000000000000000000023751260377556400204140ustar00rootroot00000000000000;; Bootstrap shrink-vector changes. (The previous derive-type ;; optimizer for shrink-vector didn't handle union types.) (in-package "C") (ext:without-package-locks ;; Just in case the compiling lisp doesn't known about lisp::shrink-vector. (defknown lisp::shrink-vector (vector fixnum) vector (unsafe) :result-not-used #'function-result-not-used-p) (defoptimizer (lisp::shrink-vector derive-type) ((vector new-size)) ;; The result of shrink-vector is another vector of the same type as ;; the input. If the size is a known constant, we use it, otherwise ;; just make the dimension unknown. (let* ((dim (if (constant-continuation-p new-size) `(,(continuation-value new-size)) '(*))) (vector-type (continuation-type vector)) (results (mapcar #'(lambda (type) (let* ((new-type (kernel::copy-array-type type))) (setf (kernel:array-type-dimensions new-type) dim) new-type)) (if (typep vector-type 'union-type) (union-type-types vector-type) (list vector-type))))) (if (rest results) (make-union-type results) (first results)))) ) (in-package "STREAM") ;; We want to use LISP::SURROGATES in the STREAM package. (ext:without-package-locks (unintern 'stream::surrogates) (import 'lisp::surrogates) ) cmucl-21a/src/bootfiles/19f/boot-2009-08-1.lisp000066400000000000000000000003671260377556400205520ustar00rootroot00000000000000;; Bootstrap file for the ef-flush changes. Just need to change the ;; value of +ef-max+ (in-package "STREAM") (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue)))) (defconstant +ef-max+ 11)) cmucl-21a/src/bootfiles/19f/boot-20a.lisp000066400000000000000000000036261260377556400201600ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20a. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20a (setf (symbol-value 'byte-fasl-file-version) #x20a) #-cmu20a (setf (backend-fasl-file-version *target-backend*) #x20a) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20a (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20a (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20a/000077500000000000000000000000001260377556400157205ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20a/boot-2009-10-01.lisp000066400000000000000000000011171260377556400206000ustar00rootroot00000000000000;; Bootstrap for non-unicode build. Just updating the +ef-foo+ values. (in-package "STREAM") (handler-bind ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (vm::defenum (:prefix "+EF-" :suffix "+" :start 1) str ; string length cin ; input a character cout ; output a character sin ; input string sout ; output string os ; octets to string so ; string to octets en ; encode de ; decode flush ; flush state copy-state ; copy state max) ) cmucl-21a/src/bootfiles/20a/boot-2009-10-1-cross.lisp000066400000000000000000000005121260377556400216450ustar00rootroot00000000000000;;; Cross-compile script to add new slots to lisp-stream so we can ;;; have faster external formats. ;; Nothing special needed; use standard scripts (load #+x86 "target:tools/cross-scripts/cross-x86-x86" #+sparc "target:tools/cross-scripts/cross-sparc-sparc" #+ppc "target:tools/cross-scripts/cross-ppc-ppc-darwin") cmucl-21a/src/bootfiles/20a/boot-2010-02-1.lisp000066400000000000000000000114111260377556400205070ustar00rootroot00000000000000;; Bootstrap file for adding support for localization. (setf lisp::*enable-package-locked-errors* nil) (defvar lisp::*environment-list-initialized* nil) (defpackage "INTL" (:use "COMMON-LISP") (:export "SETLOCALE" "TEXTDOMAIN" "GETTEXT" "DGETTEXT" "NGETTEXT" "DNGETTEXT" "READ-TRANSLATABLE-STRING" "*LOCALE-DIRECTORIES*")) (with-open-file (s "target:code/intl.lisp") (compile-from-stream s)) (intl::install) (in-package "C") ;; The textdomain for the documentation (define-info-type function textdomain (or string null) nil) (define-info-type variable textdomain (or string null) nil) (define-info-type type textdomain (or string null) nil) (define-info-type typed-structure textdomain (or string null) nil) (define-info-type setf textdomain (or string null) nil) ;;; ;;; Like DEFSTRUCT, but silently clobber old definitions. ;;; (defmacro defstruct! (name &rest stuff) `(handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct ,name ,@stuff))) (defstruct! (template (:print-function %print-template) (:pure t)) ;; ;; The symbol name of this VOP. This is used when printing the VOP and is ;; also used to provide a handle for definition and translation. (name nil :type symbol) ;; ;; A Function-Type describing the arg/result type restrictions. We compute ;; this from the Primitive-Type restrictions to make life easier for IR1 ;; phases that need to anticipate LTN's template selection. (type (required-argument) :type function-type) ;; ;; Lists of restrictions on the argument and result types. A restriction may ;; take several forms: ;; -- The restriction * is no restriction at all. ;; -- A restriction (:OR *) means that the operand must have ;; one of the specified primitive types. ;; -- A restriction (:CONSTANT ) means that the ;; argument (not a result) must be a compile-time constant that satisfies ;; the specified predicate function. In this case, the constant value ;; will be passed as an info argument rather than as a normal argument. ;; is a Lisp type specifier for the type tested by the ;; predicate, used when we want to represent the type constraint as a Lisp ;; function type. ;; ;; If Result-Types is :Conditional, then this is an IF-xxx style conditional ;; that yeilds its result as a control transfer. The emit function takes two ;; info arguments: the target label and a boolean flag indicating whether to ;; negate the sense of the test. (arg-types nil :type list) (result-types nil :type (or list (member :conditional))) ;; ;; The primitive type restriction applied to each extra argument or result ;; following the fixed operands. If NIL, no extra args/results are allowed. ;; Otherwise, either * or a (:OR ...) list as described for the ;; {ARG,RESULT}-TYPES. (more-args-type nil :type (or (member nil *) cons)) (more-results-type nil :type (or (member nil *) cons)) ;; ;; If true, this is a function that is called with no arguments to see if ;; this template can be emitted. This is used to conditionally compile for ;; different target hardware configuarations (e.g. FP hardware.) (guard nil :type (or function null)) ;; ;; The policy under which this template is the best translation. Note that ;; LTN might use this template under other policies if it can't figure our ;; anything better to do. (policy (required-argument) :type policies) ;; ;; The base cost for this template, given optimistic assumptions such as no ;; operand loading, etc. (cost (required-argument) :type index) ;; ;; If true, then a short noun-like phrase describing what this VOP "does", ;; i.e. the implementation strategy. This is for use in efficiency notes. (note nil :type (or string null)) ;; ;; The number of trailing arguments to VOP or %Primitive that we bundle into ;; a list and pass into the emit function. This provides a way to pass ;; uninterpreted stuff directly to the code generator. (info-arg-count 0 :type index) ;; ;; A function that emits the VOPs for this template. Arguments: ;; 1] Node for source context. ;; 2] IR2-Block that we place the VOP in. ;; 3] This structure. ;; 4] Head of argument TN-Ref list. ;; 5] Head of result TN-Ref list. ;; 6] If Info-Arg-Count is non-zero, then a list of the magic arguments. ;; ;; Two values are returned: the first and last VOP emitted. This vop ;; sequence must be linked into the VOP Next/Prev chain for the block. At ;; least one VOP is always emitted. (emit-function (required-argument) :type function) ;; ;; The text domain for the note. (note-domain intl::*default-domain* :type (or string null)))cmucl-21a/src/bootfiles/20a/boot-2010-04-1.lisp000066400000000000000000000004161260377556400205140ustar00rootroot00000000000000;; Bootstrap changes to intl, because the build scripts access ;; functions that don't exist in the previous version of intl. Just ;; load the old bootstrap for simplicity instead of just defining the ;; necessary functions. (load "target:bootfiles/20a/boot-2010-02-1")cmucl-21a/src/bootfiles/20a/boot-2010-06-cross-x86.lisp000066400000000000000000000003231260377556400221270ustar00rootroot00000000000000;; Cross-compile script for x86 to add new SC numbers the xmm ;; (floating-point) registers. The default cross-compile script is ;; good enough for this. #+x86 (load "target:tools/cross-scripts/cross-x86-x86") cmucl-21a/src/bootfiles/20a/boot-2010-07-1-cross.lisp000066400000000000000000000011511260377556400216430ustar00rootroot00000000000000;;; Simple cross-compile file for moving closure_tramp and ;;; undefined_tramp to Lisp assembly routines. ;;; ;;; But note that to do the cross-compile using the 2010-06 binaries, ;;; we need a cross-bootstrap file. Thus, use boot-2010-07-1.lisp as ;;; the cross-bootstrap file. The cross-compile can be done as follows: ;;; ;;; src/tools/cross-build-world.sh -rl -B src/bootfiles/20a/boot-2010-07-1.lisp ;;; src/bootfiles/20a/boot-2010-07-1-cross #+x86 (load "target:tools/cross-scripts/cross-x86-x86") #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc") cmucl-21a/src/bootfiles/20a/boot-2010-07-1.lisp000066400000000000000000000022651260377556400205230ustar00rootroot00000000000000;; Simple bootstrap file to add the documentation slot to the EFX and ;; EXTERNAL-FORMAT structure. (in-package "STREAM") (ext:without-package-locks (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::clobber-it)))) (defstruct (external-format (:conc-name ef-) (:print-function %print-external-format) (:constructor make-external-format (name efx composingp documentation &optional slots slotd))) (name (ext:required-argument) :type (or keyword cons) :read-only t) (efx (ext:required-argument) :type efx :read-only t) (composingp (ext:required-argument) :type boolean :read-only t) (slots #() :type simple-vector :read-only t) (slotd nil :type list :read-only t) (documentation nil :type (or null string) :read-only t)))) (in-package "INTL") (export '(with-textdomain)) (ext:without-package-locks (defmacro with-textdomain ((old-domain new-domain) &body body) `(progn (intl:textdomain ,new-domain) ,@body (intl:textdomain ,old-domain))) ) ;; Executable feature works on sparc! #+(or sparc (and x86 darwin)) (pushnew :executable *features*) (load "src/bootfiles/20a/boot-20b.lisp") cmucl-21a/src/bootfiles/20a/boot-2010-08-1.lisp000066400000000000000000000015541260377556400205240ustar00rootroot00000000000000;; Need to add a new ef macro id for OCTETS-TO-STRING-COUNTED. ;; ;; 2010-09 (probably) needs to be cross-compiled from 2010-08 (aka ;; 20b-pre1). Use something like ;; ;; src/tools/cross-build-world.sh -crl -B src/bootfiles/20a/boot-2010-08-1.lisp target/ cross src/tools/cross-scripts/cross-x86-x86.lisp <20b/bin/lisp> (in-package "STREAM") (ext:without-package-locks (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'kernel::continue)))) (vm::defenum (:prefix "+EF-" :suffix "+" :start 1) str ; string length cin ; input a character cout ; output a character sin ; input string sout ; output string os ; octets to string so ; string to octets en ; encode de ; decode flush ; flush state copy-state ; copy state osc max)))cmucl-21a/src/bootfiles/20a/boot-20b.lisp000066400000000000000000000036261260377556400201440ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20b. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20b (setf (symbol-value 'byte-fasl-file-version) #x20b) #-cmu20b (setf (backend-fasl-file-version *target-backend*) #x20b) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20b (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20b (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8))) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20b/000077500000000000000000000000001260377556400157215ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20b/boot-2010-11-1-cross.lisp000066400000000000000000000005041260377556400216400ustar00rootroot00000000000000;;; Bootstrap for building the 2010-12 snapshot. Adding slots to the ;;; backend requires a cross-compile. ;;; ;;; Answer CLOBBER-IT for the restart about changing the size of the ;;; backend structure. #+x86 (load "target:tools/cross-scripts/cross-x86-x86") #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc") cmucl-21a/src/bootfiles/20b/boot-2010-12.lisp000066400000000000000000000014221260377556400203540ustar00rootroot00000000000000;; Setup backend-foreign-linkage-space-start/entry-size for each ;; architecture. #+x86 (setf (c::backend-foreign-linkage-space-start c:*target-backend*) #+linux #x58000000 #-linux #xB0000000 (c::backend-foreign-linkage-entry-size c:*target-backend*) 8) #+sparc (setf (c::backend-foreign-linkage-space-start c:*target-backend*) ;; This better match the value in sparc-validate.h! #x0f800000 (c::backend-foreign-linkage-entry-size c:*target-backend*) ;; This better agree with what sparc-arch.c thinks it is! Right now, ;; it's 4 instructions, so 16 bytes. 16) #+ppc (setf (c::backend-foreign-linkage-space-start c:*target-backend*) #x17000000 (c::backend-foreign-linkage-entry-size c:*target-backend*) 32)cmucl-21a/src/bootfiles/20b/boot-2011-04-01-cross.lisp000066400000000000000000000005161260377556400217260ustar00rootroot00000000000000;; Add -unidata command line option to allow user to tell cmucl where ;; the unidata.bin file is. ;; ;; To build 2011-06, you need to do a cross-compile. Use this as the ;; cross-compile bootstrap file. #+x86 (load "target:tools/cross-scripts/cross-x86-x86.lisp") #+sparc (load "target:tools/cross-scripts/cross-sparc-sparc.lisp") cmucl-21a/src/bootfiles/20b/boot-20c.lisp000066400000000000000000000036641260377556400201500ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20c. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20c (setf (symbol-value 'byte-fasl-file-version) #x20c) #-cmu20c (setf (backend-fasl-file-version *target-backend*) #x20c) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20c (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20c (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8) :class 'binary-text-stream)) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20c/000077500000000000000000000000001260377556400157225ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp000066400000000000000000000004261260377556400222760ustar00rootroot00000000000000;;; Bootstrap for building the 2012-08 snapshot from the 2012-07 ;;; snapshot. The inline allocation routines are changing. ;;; Nothing fancy needed; just use do a simple cross-build-world using ;;; this as the script. #+x86 (load "target:tools/cross-scripts/cross-x86-x86") cmucl-21a/src/bootfiles/20c/boot-20d.lisp000066400000000000000000000036641260377556400201520ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20d. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20d (setf (symbol-value 'byte-fasl-file-version) #x20d) #-cmu20d (setf (backend-fasl-file-version *target-backend*) #x20d) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20d (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20d (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8) :class 'binary-text-stream)) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20d/000077500000000000000000000000001260377556400157235ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20d/boot-2012-12-1.lisp000066400000000000000000000002521260377556400205160ustar00rootroot00000000000000;; Add :alien-callback to *features* to build callback support for ;; platforms that support alien callbacks. #+(or x86 sparc ppc) (pushnew :alien-callback *features*) cmucl-21a/src/bootfiles/20d/boot-20e.lisp000066400000000000000000000036641260377556400201540ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20e. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20e (setf (symbol-value 'byte-fasl-file-version) #x20e) #-cmu20e (setf (backend-fasl-file-version *target-backend*) #x20e) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20e (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20e (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8) :class 'binary-text-stream)) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20e/000077500000000000000000000000001260377556400157245ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20e/boot-2014-04-cross-x86.lisp000066400000000000000000000004361260377556400221420ustar00rootroot00000000000000;; Cross-compile script needed for updating the SSE2 call-out VOP and ;; x86 call_into_c. In both places, we remove the need to do the fldz ;; and fstp dance to set up the FPU for C and Lisp. SSE2 doesn't use ;; the FPU. #+x86 (load "target:tools/cross-scripts/cross-x86-x86.lisp") cmucl-21a/src/bootfiles/20e/boot-2014-05-1.lisp000066400000000000000000000003171260377556400205250ustar00rootroot00000000000000;; Remove the UNIX package from the package use list of the VM ;; package. The UNIX package is only needed to provide the SIGCONTEXT ;; symbol, so we just prefix it everywhere. (unuse-package "UNIX" "VM") cmucl-21a/src/bootfiles/20e/boot-2014-06-1.lisp000066400000000000000000000002511260377556400205230ustar00rootroot00000000000000;; Define source-location/class info type so that code/error.lisp can ;; be compiled. (in-package c) (define-info-type source-location class (or form-numbers null) nil) cmucl-21a/src/bootfiles/20e/boot-20f.lisp000066400000000000000000000036641260377556400201560ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 20f. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu20f (setf (symbol-value 'byte-fasl-file-version) #x20f) #-cmu20f (setf (backend-fasl-file-version *target-backend*) #x20f) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu20f (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu20f (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8) :class 'binary-text-stream)) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/20f/000077500000000000000000000000001260377556400157255ustar00rootroot00000000000000cmucl-21a/src/bootfiles/20f/boot-2014-11-ppc.lisp000066400000000000000000000001141260377556400211400ustar00rootroot00000000000000;; Enable executable feature on ppc. #+ppc (pushnew :executable *features*) cmucl-21a/src/bootfiles/20f/boot-2015-06-1.lisp000066400000000000000000000134771260377556400205430ustar00rootroot00000000000000;; Fix #6. ;; ;; Use this to bootstrap the change using the snapshot-2015-06 binary. (in-package "KERNEL") (export '(invalid-case)) (in-package "CONDITIONS") (ext:without-package-locks (define-condition invalid-case (reference-condition error) ((name :initarg :name :reader invalid-case-name) (format :initarg :format-control :reader invalid-case-format) (args :initarg :format-arguments :reader invalid-case-format-args)) (:report (lambda (condition stream) (format stream "~A: " (invalid-case-name condition)) (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) (print-references (reference-condition-references condition) stream)))) ) (in-package "LISP") (ext:without-package-locks (defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise) (let ((keyform-value (gensym)) (clauses ()) (keys ())) (do* ((case-list cases (cdr case-list)) (case (first case-list) (first case-list))) ((null case-list)) (cond ((atom case) (error (intl:gettext "~S -- Bad clause in ~S.") case name)) ((and (not allow-otherwise) (memq (car case) '(t otherwise))) (cond ((null (cdr case-list)) ;; The CLHS says OTHERWISE clause is an OTHERWISE clause ;; only if it's the last case. Otherwise, it's just a ;; normal clause. (push `(t nil ,@(rest case)) clauses)) ((and (eq name 'case)) (let ((key (first case))) (error 'kernel:invalid-case :name name :format-control (intl:gettext "~<~A is a key designator only in the final otherwise-clause. ~ Use (~A) to use it as a normal-clause or move the clause to the ~ correct position.~:@>") :format-arguments (list (list key key)) :references (list '(:ansi-cl :section (5 3)) (list :ansi-cl :macro name))))) ((eq (first case) t) ;; The key T is normal clause, because it's not ;; the last clause. (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) ((and multi-p (listp (first case))) (setf keys (append (first case) keys)) (push `((or ,@(mapcar #'(lambda (key) `(,test ,keyform-value ',key)) (first case))) nil ,@(rest case)) clauses)) (t (when (and allow-otherwise (memq (car case) '(t otherwise))) (warn 'kernel:simple-style-warning :format-control (intl:gettext "Bad style to use ~S in ~S") :format-arguments (list (car case) name))) (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) (case-body-aux name keyform keyform-value clauses keys proceedp allow-otherwise `(,(if multi-p 'member 'or) ,@keys)))) ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the ;;; cases. Note: it is not necessary that the resulting code signal ;;; case-failure conditions, but that's what KMP's prototype code did. We call ;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has ;;; forms with closures that the compiler causes to be generated at the top of ;;; any function using the case macros, regardless of whether they are needed. ;;; (defun case-body-aux (name keyform keyform-value clauses keys proceedp allow-otherwise expected-type) (if proceedp (let ((block (gensym)) (again (gensym))) `(let ((,keyform-value ,keyform)) (block ,block (tagbody ,again (return-from ,block (cond ,@(nreverse clauses) (t (setf ,keyform-value (setf ,keyform (case-body-error ',name ',keyform ,keyform-value ',expected-type ',keys))) (go ,again)))))))) `(let ((,keyform-value ,keyform)) ,keyform-value ; prevent warnings when key not used eg (case key (t)) (cond ,@(nreverse clauses) ,@(if allow-otherwise `((t (error 'conditions::case-failure :name ',name :datum ,keyform-value :expected-type ',expected-type :possibilities ',keys)))))))) (defmacro case (keyform &body cases) "CASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If a singleton key is T or Otherwise then the clause is a default clause." (case-body 'case keyform cases t 'eql nil)) (defmacro ccase (keyform &body cases) "CCASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then a correctable error is signalled." (case-body 'ccase keyform cases t 'eql t t)) (defmacro ecase (keyform &body cases) "ECASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then an error is signalled." (case-body 'ecase keyform cases t 'eql nil t)) (defmacro typecase (keyform &body cases) "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If a singleton key is T or Otherwise then the clause is a default clause." (case-body 'typecase keyform cases nil 'typep nil)) (defmacro ctypecase (keyform &body cases) "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." (case-body 'ctypecase keyform cases nil 'typep t t)) (defmacro etypecase (keyform &body cases) "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." (case-body 'etypecase keyform cases nil 'typep nil t)) ) cmucl-21a/src/bootfiles/20f/boot-20f-cross-x86.lisp000066400000000000000000000005141260377556400217200ustar00rootroot00000000000000;;; Cross-compile script to update extern-alien-name for ;;; darwin/x86. This makes extern-alien-name on darwin/x86 match ;;; darwin/ppc, where an underscore is prepended. ;;; ;;; A cross-compile might not truly be necessary, but this is known to ;;; work. #+(and darwin x86) (load "target:tools/cross-scripts/cross-x86-x86.lisp") cmucl-21a/src/bootfiles/20f/boot-21a.lisp000066400000000000000000000036641260377556400201530ustar00rootroot00000000000000;;;; ;;;; Boot file for changing the fasl file version numbers to 21a. ;;;; (in-package :c) (setf lisp::*enable-package-locked-errors* nil) ;;; ;;; Note that BYTE-FASL-FILE-VERSION is a constant. ;;; ;;; (Be sure to change BYTE-FASL-FILE-VERSION in ;;; compiler/byte-comp.lisp to the correct value too!) ;;; #-cmu21a (setf (symbol-value 'byte-fasl-file-version) #x21a) #-cmu21a (setf (backend-fasl-file-version *target-backend*) #x21a) ;;; ;;; Don't check fasl versions in the compiling Lisp because we'll ;;; load files compiled with the new version numbers. ;;; #-cmu21a (setq lisp::*skip-fasl-file-version-check* t) ;;; ;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in ;;; OPEN-FASL-FILE. To make the new version number take effect, we ;;; have to redefine the function. ;;; #-cmu21a (defun open-fasl-file (name where &optional byte-p) (declare (type pathname name)) (let* ((stream (open name :direction :output :if-exists :new-version :element-type '(unsigned-byte 8) :class 'binary-text-stream)) (res (make-fasl-file :stream stream))) (multiple-value-bind (version f-vers f-imp) (if byte-p (values "Byte code" byte-fasl-file-version (backend-byte-fasl-file-implementation *backend*)) (values (backend-version *backend*) (backend-fasl-file-version *backend*) (backend-fasl-file-implementation *backend*))) (format stream "FASL FILE output from ~A.~@ Compiled ~A on ~A~@ Compiler ~A, Lisp ~A~@ Targeted for ~A, FASL version ~X~%" where (ext:format-universal-time nil (get-universal-time)) (machine-instance) compiler-version (lisp-implementation-version) version f-vers) ;; ;; Terminate header. (dump-byte 255 res) ;; ;; Specify code format. (dump-fop 'lisp::fop-long-code-format res) (dump-byte f-imp res) (dump-unsigned-32 f-vers res)) res)) cmucl-21a/src/bootfiles/README000066400000000000000000000031451260377556400162210ustar00rootroot00000000000000The nameing of the bootfiles have been historically inconsistent. To fix that here is the convention to be used for all bootfiles after 2014-07. 1. The bootfile must reside in the directory whose name is the current CMUCL version for which this bootfile applies. For example, as of this writing, the current version is 20e, so boot files must be in the 20e directory. 2. The name of the boot file shall be boot-yyyy-mm-n.lisp where yyyy-mm represents the year (yyyy) and month (mm) of the snapshot that is used to build from. The boot files are numbered sequentially from 1 (n). Thus, the boot-2014-06-1.lisp is intended to be built from the 2014-06 snapshot, and is the first boot file to be applied. 3. The boot file should describe what it is for. If a cross-compile script is needed, we also have similar rules. 1. The script must be in the version directory, as for boot files. 2. The names of the script file must have to format boot-yyyy-mm-n-cross-aaa.lisp where yyyy, mm, and n have the same meaning as for boot files above. A. The aaa field is flexible. 1. If it is not included, then the script is intended to be applicable to all architectures. If aaa is given, then it is meant to be applied only for the architecture aaa. 2. If the scrit is applicable to more than one architecture, the aaa field is dropped and the script must take care to include conditionals so that the script can be applied to all architectures. B. Additional information can be included if desired. 3. The script should describe what it is for. cmucl-21a/src/clx/000077500000000000000000000000001260377556400141365ustar00rootroot00000000000000cmucl-21a/src/clx/CHANGES000066400000000000000000000034101260377556400151270ustar00rootroot00000000000000$Id: CHANGES,v 1.7 2009/06/17 18:22:45 rtoy Rel $ Details of changes since R5: NOTE: this file is not updated any more. Changes since checking into version control can be found from darcs in some way shape or form. There may however be some Dark Ages between when this file was last updated and the version that was the initial version control checkin. Changes in CLX 5.02: Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE. Fix a declaration in the DEFINE-ERROR macro. Quote type argument to TYPE-CHECK consistently. Changes in CLX 5.01: Support for MIT-MAGIC-COOKIE-1 authorization has been added. All VALUES declarations have been changed to CLX-VALUES declarations. VALUES is a CL type name and cannot be used as a declaration name. All ARRAY-REGISTER declarations have been removed as Genera no longer needs them. Many type declarations have been corrected or tightened up now that some Lisps look at them. Print functions have been defined for bitmap and pixmap formats. The DISPLAY-PLIST slot will be initialized to NIL. When debugging, don't optimize SPEED in the buffer macros. Make the CARD8<->CHAR and the window manager code work for sparse character sets (where some codes do not have corresponding characters). The default gcontext extension set and copy functions will take the correct number of arguments. PUT-IMAGE will now work for 24-bit images. The buffer accessors for MEMBER8, etc., will use the standard mechanisms for reporting type errors. Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and POINTER-CONTROL have been fixed. Symbolics systems will do lazy macroexpansion in the buffer macros. A variety of changes for Symbolics Minima systems have been made. Some system-dependent code has been added for CMU Common Lisp. cmucl-21a/src/clx/NEWS000066400000000000000000000134261260377556400146430ustar00rootroot00000000000000-*- Text -*- $Id: NEWS,v 1.3 2009/06/17 18:22:45 rtoy Rel $ -- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- Support for Allegro CL (6.2 and later) (Mikel Evins) Latin 1 keysyms (Christophe Rhodes) Some protocol fixes (Douglas Crosher) Define a RENDER-OP typ (Douglas Crosher) --- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 --- OpenMCL fixes DPMS extension support Xauthority ipv6 parsing fixes Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes --- Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 --- Works in SBCL 0.9.2 and newer. --- Changes in SBCL CLX 0.7.0, Sun May 1 2005 --- The SBCL support now depends on version 0.9.0 or greater. --- Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 --- experimental GLX extension support (from Janis Dzerins) The ICCCM-compliant selection handling in demo/clipboard.lisp is now more ICCCM-compliant. The implementation of the RENDER client protocol has been enhanced. (Gilbert Baumann) Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input event descriptions have been fixed. --- Changes in SBCL CLX 0.6, Tue Nov 16 2004 --- A port to ECL has been merged (Juan Jose Garcia Ripoll) With the addition of an implementation of DYNAMIC-EXTENT &REST lists to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX should cons less. A Texinfo version of the CLX manual has been added (in manual/), thanks to the work of Gilbert Baumann and Shawn Betts. The portable-clx mailing list has been created for development discussion and bug reports. See http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx A demonstration of ICCCM-compliant selection handling for select and paste has been included in demo/clipboard.lisp Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32 bits wide, as per the ICCCM specifications. Fixes a problem seen with the MacOS X11 window manger, that uses very large hint values. (Patch from Eric Marsden) Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of keywords. It wasn't, but it is now. (Milan Zamazal) Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS* (Milan again) --- Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003 --- A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP under multithreaded SBCL. Previous versions used queues and condition variables, but this seems to have undesireable performance characteristics; the newer version uses a polling loop calling sched_yield() inside, which greatly improves responsiveness, but is more CPU-hungry (as perceived by top(1), at least; in theory it only hogs the CPU when nobody else wants it). --- Changes in SBCL CLX 0.5.3, Sat Sep 6 12:14:39 UTC 2003 --- We allow a PIXMAP-DEPTH of 12 in clx.lisp, despite not having any image routines for it, to allow clx to load when running under eXceed. Image routines are unlikely to work in such circumstances. Bug fixes * ERROR idiom (xvidmode.lisp) * Add timestamp in NEWS file --- Changes in SBCL CLX 0.5.2, about twenty minutes before 0.5.3 --- OPEN-DEFAULT-DISPLAY now takes an optional argument for the display name, which has the same "protocol/host:display.screen" format as used by the C libX11 (XOpenDisplay). OPEN-DISPLAY is not actively deprecated, but is much less useful by comparison Inclusion of two new tests/demos (from Ingvar Mattson): * demo/clclock: a simple clock application; * demo/mandel: a Mandelbrot set viewer. Bug fixes * Fix bad type declarations in TEXT-EXTENTS-SERVER and TEXT-WIDTH-SERVER (text.lisp) * Fix FORMAT argument mismatch error in WRITE-BITMAP-FILE (image.lisp) --- Changes in SBCL CLX 0.5.1, Wed Jun 25 14:20:31 BST 2003 --- experimental RENDER extension support (from Gilbert Baumann) note: the API to this is as yet unfinalized, as indeed the protocol and specification appear to be in flux. Nevertheless, feedback is welcome to the portable-clx-devel mailing list. Bug fixes * fix bugs in the image test: always draw glyphs in white on black (not 1 on 0 -- i.e. dark red/blue on black in 24 bit truecolour); don't abuse the X-HOT and Y-HOT slots for communicating persistent information any more. * Disable the "optimized" pixarray read/write routines, on the basis that the newly fixed image test reveals that they are broken. * fix type bugs in DEFINE-GCONTEXT-ACCESSOR, which previously signalled a type error if :COPY-FUNCTION was not provided, and a different type error if it was. Other notes * we use the SBCL extensions to the condition system to customize compiler behaviour. As such, the system will only build without breaking into the debugger using the supplied .asd, as we inhibit error signalling from DEFCONSTANT; the benefits of this are easier code sharing, as we minimize divergence within the clx source proper from other implementations. * we also use an SBCL extension to maximize efficiency: we set SB-EXT:*DERIVE-FUNCTION-TYPES* to true for the duration of the compilation of the clx library. Should functions in CLX be redefined in a type-incompatible way, their callers in CLX (but not outside) will need to be recompiled. --- Changes in SBCL CLX 0.5, Fri May 30 01:16:34 BST 2003 --- XFree86-VidModeExtension extension support (courtesy of Iban Hatchondo) OPEN-DEFAULT-DISPLAY (opens display in $DISPLAY environment variable) exported Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc Many bug fixes * asking for text extents on unchached fonts could potentially deadlock http://article.gmane.org/gmane.lisp.clx.devel/16 * lots of compiler warnings, style-warnings, notes cleared up Style and ANSI cleanups * Much renaming of constants from *foo* to +foo+ * Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs. cmucl-21a/src/clx/README000066400000000000000000000077121260377556400150250ustar00rootroot00000000000000$Id: README,v 1.6 2009/06/17 18:22:45 rtoy Rel $ This directory contains CLX, an X11 client library for Common Lisp. The code was originally taken from a CMUCL distribution, was modified somewhat in order to make it compile and run under SBCL, then a selection of patches were added from other CLXes around the net. = Features - SHAPE extension support (Gilbert Baumann) - XFREE86-VIDMODE extension support (Iban Hatchondo) - experimental RENDER extension support (Gilbert Baumann and Christian Sunesson) - X authority support that works with ssh forwarding (Eric Marsden via CMUCL) - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan) - various bug fixes (Iban Hatchondo and a cast of several) - a manual in texinfo format (Shawn Betts, Gilbert Baumann) = Compatibility This CLX distribution is intended to work under the latest released version of SBCL - please report the bug if it doesn't. It should usually also work with earlier versions back to 0.9.0, and possibly earlier still, but may need manual adjustment to the clx.asd file (to remove use of newly-introduced features). It has also been used as a basis for CLX ports on other Lisp implementations, but these instructions are only good for SBCL. If you're running something else, you need to know (a) that it builds with asdf (and asdf-install, if the planets are in alignment) and (b) what asdf is anyway. http://www.weitz.de/asdf-install/ might help you there. If you've installed this using some non-SBCL Lisp, please send mail describing the process so that future versions can incorporate your instructions. If you are following SBCL CVS and this CLX does not run in it, please check the darcs repositor{y,ies} for this CLX distribution to see if your bug has been fixed already. darcs get http://verisons.telent.net/clx # version from which releases are made http://common-lisp.net/~crhodes/clx # patches merged by Christophe http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor? = Building using asdf-install * (require 'asdf) * (require 'asdf-install) * (asdf-install:install 'clx) ; download and install automatically, or * (asdf-install:install "clx-x.y.z.tar.gz") ; if you've downloaded already = Building by hand If you don't trust asdf-install, here's how to do it manually - 1. Untar this tree somewhere 2. Add a symlink to clx.asd from one of the directories listed in your asdf:*central-registry* If that makes no sense to you yet, choose one of - 2a. personal installation: $ cd $HOME/.sbcl/systems # you may have to create this directory $ ln -s /path/to/clx/source/clx.asd . 2b. systemwide installations: you need to ask SBCL where it lives $ sbcl --noinform --eval '(format t "~A~%" (posix-getenv "SBCL_HOME"))' ASDFized version and ongoing by Daniel Barlow and (mostly, these days) Christophe Rhodes cmucl-21a/src/clx/README-CMUCL000066400000000000000000000013671260377556400156660ustar00rootroot00000000000000$Id: README-CMUCL,v 1.2 2009/06/11 16:03:56 rtoy Rel $ This is an import of Telent-CLX as of 0.7.3. All files are included. A few changes to fix bugs related to CMUCL have been added, as well as the CVS id. I've tried to make few changes so it will be easy to merge again when desired. The following files from this directory are compiled and loaded by CMUCL when it builds utilities: clx-library.lisp package.lisp depdefs.lisp clx.lisp dependent.lisp macros.lisp bufmac.lisp buffer.lisp display.lisp gcontext.lisp input.lisp requests.lisp fonts.lisp graphics.lisp text.lisp attributes.lisp translate.lisp keysyms.lisp manager.lisp image.lisp resource.lisp shape.lisp big-requests.lisp xvidmode.lisp xrender.lisp glx.lisp gl.lisp dpms.lisp provide.lisp cmucl-21a/src/clx/README-R5000066400000000000000000000036421260377556400153070ustar00rootroot00000000000000$Id: README-R5,v 1.2 2009/06/17 18:22:45 rtoy Rel $ Original CLX README, retained for historical information --- These files contain beta code, but they have been tested to some extent under Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep them within 12 characters, to keep SysV sites happy. Please rename them with more appropriate suffixes for your system. For Franz systems, see exclREADME. For Symbolics systems, first rename all the .l files to .lisp. Then edit your sys.translations file so that sys:x11;clx; points to this directory and put a clx.system file in your sys:site;directory that has the form (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") in it. After that CLX can be compiled with the "Compile System CLX" command and loaded with the "Load System CLX" command. For TI systems, rename all the .l files to .lisp, and make a clx.translations file in your sys:site; directory pointing to this directory and a sys:site;clx.system file like the one described for symbolics systems above, but with the defsystem file being in the clx:clx; directory. Then CLX can be compiled with (make-system "CLX" :compile :noconfirm) and loaded with (make-system "CLX" :noconfirm). For Lucid systems, you should rename all the .l files to .lisp too (This might not be possible on SysV systems). After loading the defsystem.l file, CLX can be compiled with the (compile-clx) function and loaded with the (load-clx) form. The ms-patch.uu file is a patch to Lucid version 2 systems. You probably don't need it, as you are probably running Lucid version 3 or later, but if you are still using Lucid version 2, you need this patch. You'll need to uudecode it to produce the binary. For kcl systems, after loading the defsystem.l file, CLX can be compiled with the (compile-clx) function and loaded with the (load-clx) form. For more information, see defsystem.l and provide.l. cmucl-21a/src/clx/attributes.lisp000066400000000000000000000571771260377556400172360ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; Window Attributes ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; The special variable *window-attributes* is an alist containg: ;;; (drawable attributes attribute-changes geometry geometry-changes) ;;; Where DRAWABLE is the associated window or pixmap ;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's ;;; attributes for use by the accessors. ;;; ATTRIBUTE-CHANGES is NIL or an array. The first element ;;; of the array is a "value-mask", indicating which ;;; attributes have changed. The other elements are ;;; integers associated with the changed values, ready ;;; for insertion into a server request. ;;; GEOMETRY is like ATTRIBUTES, but for window geometry ;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry ;;; ;;; Attribute and Geometry accessors and SETF's look on the special variable ;;; *window-attributes* for the drawable. If its not there, the accessor is ;;; NOT within a WITH-STATE, and a server request is made to get or put a value. ;;; If an entry is found in *window-attributes*, the cache buffers are used ;;; for the access. ;;; ;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including ;;; the new drawable. The caches are initialized to NIL and allocated as needed. #+cmu (ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +attribute-size+ 44) (defconstant +geometry-size+ 24) (defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4)))) (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE ;; Window Attribute reply buffer resource (defvar *context-free-list* nil) ;; resource of free reply buffers (defun allocate-context () (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer) (make-reply-buffer +context-size+))) (defun deallocate-context (context) (declare (type reply-buffer context)) (threaded-atomic-push context *context-free-list* reply-next reply-buffer)) (defmacro state-attributes (state) `(second ,state)) (defmacro state-attribute-changes (state) `(third ,state)) (defmacro state-geometry (state) `(fourth ,state)) (defmacro state-geometry-changes (state) `(fifth ,state)) (defmacro drawable-equal-function () ;; Since drawables are not always cached, we must use drawable-equal ;; to determine equality. ''drawable-equal) (defmacro window-equal-function () ;; Since windows are not always cached, we must use window-equal ;; to determine equality. ''window-equal) (defmacro with-state ((drawable) &body body) ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and ;; ConfigureWindow. The body is not surrounded by a with-display. Within the ;; indefinite scope of the body, on a per-process basis in a multi-process ;; environment, the first call within an Accessor Group on the specified drawable ;; (the object, not just the variable) causes the complete results of the protocol ;; request to be retained, and returned in any subsequent accessor calls. Calls ;; within a Setf Group are delayed, and executed in a single request on exit from ;; the body. In addition, if a call on a function within an Accessor Group follows ;; a call on a function in the corresponding Setf Group, then all delayed setfs for ;; that group are executed, any retained accessor information for that group is ;; discarded, the corresponding protocol request is (re)issued, and the results are ;; (again) retained, and returned in any subsequent accessor calls. ;; Accessor Group A (for GetWindowAttributes): ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity, ;; window-backing-store, window-backing-planes, window-backing-pixel, ;; window-save-under, window-colormap, window-colormap-installed-p, ;; window-map-state, window-all-event-masks, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect ;; Setf Group A (for ChangeWindowAttributes): ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, ;; window-backing-pixel, window-save-under, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, ;; window-cursor ;; Accessor Group G (for GetGeometry): ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, ;; drawable-height, drawable-border-width ;; Setf Group G (for ConfigureWindow): ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, ;; window-priority (let ((state-entry (gensym))) ;; alist of (drawable attributes attribute-changes geometry geometry-changes) `(with-stack-list (,state-entry ,drawable nil nil nil nil) (with-stack-list* (*window-attributes* ,state-entry *window-attributes*) (multiple-value-prog1 (progn ,@body) (cleanup-state-entry ,state-entry)))))) (defun cleanup-state-entry (state) ;; Return buffers to the free-list (let ((entry (state-attributes state))) (when entry (deallocate-context entry))) (let ((entry (state-attribute-changes state))) (when entry (put-window-attribute-changes (car state) entry) (deallocate-gcontext-state entry))) (let ((entry (state-geometry state))) (when entry (deallocate-context entry))) (let ((entry (state-geometry-changes state))) (when entry (put-drawable-geometry-changes (car state) entry) (deallocate-gcontext-state entry)))) (defun change-window-attribute (window number value) ;; Called from window attribute SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type window window) (type card8 number) (type card32 value)) (let ((state-entry nil) (changes nil)) (if (and *window-attributes* (setq state-entry (assoc window (the list *window-attributes*) :test (window-equal-function)))) (progn ; Within a WITH-STATE - cache changes (setq changes (state-attribute-changes state-entry)) (unless changes (setq changes (allocate-gcontext-state)) (setf (state-attribute-changes state-entry) changes) (setf (aref changes 0) 0)) ;; Initialize mask to zero (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server (with-buffer-request ((window-display window) +x-changewindowattributes+) (window window) (card32 (ash 1 number) value))))) ;; ;; These two are twins (change-window-attribute change-drawable-geometry) ;; If you change one, you probably need to change the other... ;; (defun change-drawable-geometry (drawable number value) ;; Called from drawable geometry SETF's to alter an attribute value ;; number is the change-attributes request mask bit number (declare (type drawable drawable) (type card8 number) (type card29 value)) (let ((state-entry nil) (changes nil)) (if (and *window-attributes* (setq state-entry (assoc drawable (the list *window-attributes*) :test (drawable-equal-function)))) (progn ; Within a WITH-STATE - cache changes (setq changes (state-geometry-changes state-entry)) (unless changes (setq changes (allocate-gcontext-state)) (setf (state-geometry-changes state-entry) changes) (setf (aref changes 0) 0)) ;; Initialize mask to zero (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit (setf (aref changes (1+ number)) value)) ;; save value ; Send change to the server (with-buffer-request ((drawable-display drawable) +x-configurewindow+) (drawable drawable) (card16 (ash 1 number)) (card29 value))))) (defun get-window-attributes-buffer (window) (declare (type window window)) (let ((state-entry nil) (changes nil)) (or (and *window-attributes* (setq state-entry (assoc window (the list *window-attributes*) :test (window-equal-function))) (null (setq changes (state-attribute-changes state-entry))) (state-attributes state-entry)) (let ((display (window-display window))) (with-display (display) ;; When SETF's have been done, flush changes to the server (when changes (put-window-attribute-changes window changes) (deallocate-gcontext-state (state-attribute-changes state-entry)) (setf (state-attribute-changes state-entry) nil)) ;; Get window attributes (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8)) ((window window)) (let ((repbuf (or (state-attributes state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) ;; Copy into repbuf from reply buffer (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) (when state-entry (setf (state-attributes state-entry) repbuf)) repbuf))))))) ;; ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer) ;; If you change one, you probably need to change the other... ;; (defun get-drawable-geometry-buffer (drawable) (declare (type drawable drawable)) (let ((state-entry nil) (changes nil)) (or (and *window-attributes* (setq state-entry (assoc drawable (the list *window-attributes*) :test (drawable-equal-function))) (null (setq changes (state-geometry-changes state-entry))) (state-geometry state-entry)) (let ((display (drawable-display drawable))) (with-display (display) ;; When SETF's have been done, flush changes to the server (when changes (put-drawable-geometry-changes drawable changes) (deallocate-gcontext-state (state-geometry-changes state-entry)) (setf (state-geometry-changes state-entry) nil)) ;; Get drawable attributes (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8)) ((drawable drawable)) (let ((repbuf (or (state-geometry state-entry) (allocate-context)))) (declare (type reply-buffer repbuf)) ;; Copy into repbuf from reply buffer (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size) (when state-entry (setf (state-geometry state-entry) repbuf)) repbuf))))))) (defun put-window-attribute-changes (window changes) ;; change window attributes ;; Always from Called within a WITH-DISPLAY (declare (type window window) (type gcontext-state changes)) (let* ((display (window-display window)) (mask (aref changes 0))) (declare (type display display) (type mask32 mask)) (with-buffer-request (display +x-changewindowattributes+) (window window) (card32 mask) (progn ;; Insert a word in the request for each one bit in the mask (do ((bits mask (ash bits -1)) (request-size 2) ;Word count (i 1 (index+ i 1))) ;Entry count ((zerop bits) (card16-put 2 (index-incf request-size)) (index-incf (buffer-boffset display) (index* request-size 4))) (declare (type mask32 bits) (type array-index i request-size)) (when (oddp bits) (card32-put (index* (index-incf request-size) 4) (aref changes i)))))))) ;; ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes) ;; If you change one, you probably need to change the other... ;; (defun put-drawable-geometry-changes (window changes) ;; change window attributes or geometry (depending on request-number...) ;; Always from Called within a WITH-DISPLAY (declare (type window window) (type gcontext-state changes)) (let* ((display (window-display window)) (mask (aref changes 0))) (declare (type display display) (type mask16 mask)) (with-buffer-request (display +x-configurewindow+) (window window) (card16 mask) (progn ;; Insert a word in the request for each one bit in the mask (do ((bits mask (ash bits -1)) (request-size 2) ;Word count (i 1 (index+ i 1))) ;Entry count ((zerop bits) (card16-put 2 (incf request-size)) (index-incf (buffer-boffset display) (* request-size 4))) (declare (type mask16 bits) (type fixnum request-size) (type array-index i)) (when (oddp bits) (card29-put (* (incf request-size) 4) (aref changes i)))))))) (defmacro with-attributes ((window &rest options) &body body) `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window))) (declare (type reply-buffer .with-attributes-reply-buffer.)) (prog1 (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body) (unless *window-attributes* (deallocate-context .with-attributes-reply-buffer.))))) ;; ;; These two are twins (with-attributes with-geometry) ;; If you change one, you probably need to change the other... ;; (defmacro with-geometry ((window &rest options) &body body) `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window))) (declare (type reply-buffer .with-geometry-reply-buffer.)) (prog1 (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body) (unless *window-attributes* (deallocate-context .with-geometry-reply-buffer.))))) ;;;----------------------------------------------------------------------------- ;;; Group A: (for GetWindowAttributes) ;;;----------------------------------------------------------------------------- (defun window-visual (window) (declare (type window window)) (declare (clx-values resource-id)) (with-attributes (window :sizes 32) (resource-id-get 8))) (defun window-visual-info (window) (declare (type window window)) (declare (clx-values visual-info)) (with-attributes (window :sizes 32) (visual-info (window-display window) (resource-id-get 8)))) (defun window-class (window) (declare (type window window)) (declare (clx-values (member :input-output :input-only))) (with-attributes (window :sizes 16) (member16-get 12 :copy :input-output :input-only))) (defun set-window-background (window background) (declare (type window window) (type (or (member :none :parent-relative) pixel pixmap) background)) (cond ((eq background :none) (change-window-attribute window 0 0)) ((eq background :parent-relative) (change-window-attribute window 0 1)) ((integerp background) ;; Background pixel (change-window-attribute window 0 0) ;; pixmap :NONE (change-window-attribute window 1 background)) ((type? background 'pixmap) ;; Background pixmap (change-window-attribute window 0 (pixmap-id background))) (t (x-type-error background '(or (member :none :parent-relative) integer pixmap)))) background) #+Genera (eval-when (compile) (compiler:function-defined 'window-background)) (defsetf window-background set-window-background) (defun set-window-border (window border) (declare (type window window) (type (or (member :copy) pixel pixmap) border)) (cond ((eq border :copy) (change-window-attribute window 2 0)) ((type? border 'pixmap) ;; Border pixmap (change-window-attribute window 2 (pixmap-id border))) ((integerp border) ;; Border pixel (change-window-attribute window 3 border)) (t (x-type-error border '(or (member :copy) integer pixmap)))) border) #+Genera (eval-when (compile) (compiler:function-defined 'window-border)) (defsetf window-border set-window-border) (defun window-bit-gravity (window) ;; setf'able (declare (type window window)) (declare (clx-values bit-gravity)) (with-attributes (window :sizes 8) (member8-vector-get 14 +bit-gravity-vector+))) (defun set-window-bit-gravity (window gravity) (change-window-attribute window 4 (encode-type (member-vector +bit-gravity-vector+) gravity)) gravity) (defsetf window-bit-gravity set-window-bit-gravity) (defun window-gravity (window) ;; setf'able (declare (type window window)) (declare (clx-values win-gravity)) (with-attributes (window :sizes 8) (member8-vector-get 15 +win-gravity-vector+))) (defun set-window-gravity (window gravity) (change-window-attribute window 5 (encode-type (member-vector +win-gravity-vector+) gravity)) gravity) (defsetf window-gravity set-window-gravity) (defun window-backing-store (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :not-useful :when-mapped :always))) (with-attributes (window :sizes 8) (member8-get 1 :not-useful :when-mapped :always))) (defun set-window-backing-store (window when) (change-window-attribute window 6 (encode-type (member :not-useful :when-mapped :always) when)) when) (defsetf window-backing-store set-window-backing-store) (defun window-backing-planes (window) ;; setf'able (declare (type window window)) (declare (clx-values pixel)) (with-attributes (window :sizes 32) (card32-get 16))) (defun set-window-backing-planes (window planes) (change-window-attribute window 7 (encode-type card32 planes)) planes) (defsetf window-backing-planes set-window-backing-planes) (defun window-backing-pixel (window) ;; setf'able (declare (type window window)) (declare (clx-values pixel)) (with-attributes (window :sizes 32) (card32-get 20))) (defun set-window-backing-pixel (window pixel) (change-window-attribute window 8 (encode-type card32 pixel)) pixel) (defsetf window-backing-pixel set-window-backing-pixel) (defun window-save-under (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :off :on))) (with-attributes (window :sizes 8) (member8-get 24 :off :on))) (defun set-window-save-under (window when) (change-window-attribute window 10 (encode-type (member :off :on) when)) when) (defsetf window-save-under set-window-save-under) (defun window-override-redirect (window) ;; setf'able (declare (type window window)) (declare (clx-values (member :off :on))) (with-attributes (window :sizes 8) (member8-get 27 :off :on))) (defun set-window-override-redirect (window when) (change-window-attribute window 9 (encode-type (member :off :on) when)) when) (defsetf window-override-redirect set-window-override-redirect) (defun window-event-mask (window) ;; setf'able (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 36))) (defsetf window-event-mask (window) (event-mask) (let ((em (gensym))) `(let ((,em ,event-mask)) (declare (type event-mask ,em)) (change-window-attribute ,window 11 (encode-event-mask ,em)) ,em))) (defun window-do-not-propagate-mask (window) ;; setf'able (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 40))) (defsetf window-do-not-propagate-mask (window) (device-event-mask) (let ((em (gensym))) `(let ((,em ,device-event-mask)) (declare (type device-event-mask ,em)) (change-window-attribute ,window 12 (encode-device-event-mask ,em)) ,em))) (defun window-colormap (window) (declare (type window window)) (declare (clx-values (or null colormap))) (with-attributes (window :sizes 32) (let ((id (resource-id-get 28))) (if (zerop id) nil (let ((colormap (lookup-colormap (window-display window) id))) (unless (colormap-visual-info colormap) (setf (colormap-visual-info colormap) (visual-info (window-display window) (resource-id-get 8)))) colormap))))) (defun set-window-colormap (window colormap) (change-window-attribute window 13 (encode-type (or (member :copy) colormap) colormap)) colormap) (defsetf window-colormap set-window-colormap) (defun window-cursor (window) (declare (type window window)) (declare (clx-values cursor)) window (error "~S can only be set" 'window-cursor)) (defun set-window-cursor (window cursor) (change-window-attribute window 14 (encode-type (or (member :none) cursor) cursor)) cursor) (defsetf window-cursor set-window-cursor) (defun window-colormap-installed-p (window) (declare (type window window)) (declare (clx-values generalized-boolean)) (with-attributes (window :sizes 8) (boolean-get 25))) (defun window-all-event-masks (window) (declare (type window window)) (declare (clx-values mask32)) (with-attributes (window :sizes 32) (card32-get 32))) (defun window-map-state (window) (declare (type window window)) (declare (clx-values (member :unmapped :unviewable :viewable))) (with-attributes (window :sizes 8) (member8-get 26 :unmapped :unviewable :viewable))) ;;;----------------------------------------------------------------------------- ;;; Group G: (for GetGeometry) ;;;----------------------------------------------------------------------------- (defun drawable-root (drawable) (declare (type drawable drawable)) (declare (clx-values window)) (with-geometry (drawable :sizes 32) (window-get 8 (drawable-display drawable)))) (defun drawable-x (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values int16)) (with-geometry (drawable :sizes 16) (int16-get 12))) (defun set-drawable-x (drawable x) (change-drawable-geometry drawable 0 (encode-type int16 x)) x) (defsetf drawable-x set-drawable-x) (defun drawable-y (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values int16)) (with-geometry (drawable :sizes 16) (int16-get 14))) (defun set-drawable-y (drawable y) (change-drawable-geometry drawable 1 (encode-type int16 y)) y) (defsetf drawable-y set-drawable-y) (defun drawable-width (drawable) ;; setf'able ;; Inside width, excluding border. (declare (type drawable drawable)) (declare (clx-values card16)) (with-geometry (drawable :sizes 16) (card16-get 16))) (defun set-drawable-width (drawable width) (change-drawable-geometry drawable 2 (encode-type card16 width)) width) (defsetf drawable-width set-drawable-width) (defun drawable-height (drawable) ;; setf'able ;; Inside height, excluding border. (declare (type drawable drawable)) (declare (clx-values card16)) (with-geometry (drawable :sizes 16) (card16-get 18))) (defun set-drawable-height (drawable height) (change-drawable-geometry drawable 3 (encode-type card16 height)) height) (defsetf drawable-height set-drawable-height) (defun drawable-depth (drawable) (declare (type drawable drawable)) (declare (clx-values card8)) (with-geometry (drawable :sizes 8) (card8-get 1))) (defun drawable-border-width (drawable) ;; setf'able (declare (type drawable drawable)) (declare (clx-values integer)) (with-geometry (drawable :sizes 16) (card16-get 20))) (defun set-drawable-border-width (drawable width) (change-drawable-geometry drawable 4 (encode-type card16 width)) width) (defsetf drawable-border-width set-drawable-border-width) (defun set-window-priority (mode window sibling) (declare (type (member :above :below :top-if :bottom-if :opposite) mode) (type window window) (type (or null window) sibling)) (with-state (window) (change-drawable-geometry window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode)) (when sibling (change-drawable-geometry window 5 (encode-type window sibling)))) mode) #+Genera (eval-when (compile) (compiler:function-defined 'window-priority)) (defsetf window-priority (window &optional sibling) (mode) ;; A bit strange, but retains setf form. `(set-window-priority ,mode ,window ,sibling)) cmucl-21a/src/clx/big-requests.lisp000066400000000000000000000023751260377556400174500ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; ;;; (c) copyright 2006 Richard Kreuter ;;; (c) copyright 2007 by Christophe Rhodes ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. #+cmu (ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big ;;; Requests Extension, section 3) ;;; ;;; The name of this extension is "BIG-REQUESTS" (Big Requests ;;; Extension, section 4) (define-extension "BIG-REQUESTS") (defun enable-big-requests (display) (declare (type display display)) (let ((opcode (extension-opcode display "BIG-REQUESTS"))) (with-buffer-request-and-reply (display opcode nil) ((data 0)) (let ((maximum-request-length (card32-get 8))) (setf (display-extended-max-request-length display) maximum-request-length))))) cmucl-21a/src/clx/buffer.lisp000066400000000000000000001462271260377556400163140ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the BUFFER object for Common-Lisp X ;;; windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;; A few notes: ;; ;; 1. The BUFFER implements a two-way buffered byte / half-word ;; / word stream. Hooks are left for implementing this with a ;; shared memory buffer, or with effenciency hooks to the network ;; code. ;; ;; 2. The BUFFER object uses overlapping displaced arrays for ;; inserting and removing bytes half-words and words. ;; ;; 3. The BYTE component of these arrays is written to a STREAM ;; associated with the BUFFER. The stream has its own buffer. ;; This may be made more efficient by using the Zetalisp ;; :Send-Output-Buffer operation. ;; ;; 4. The BUFFER object is INCLUDED in the DISPLAY object. ;; This was done to reduce access time when sending requests, ;; while maintaing some code modularity. ;; Several buffer functions are duplicated (with-buffer, ;; buffer-force-output, close-buffer) to keep the naming ;; conventions consistent. ;; ;; 5. A nother layer of software is built on top of this for generating ;; both client and server interface routines, given a specification ;; of the protocol. (see the INTERFACE file) ;; ;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to ;; a point after a complete request. This is to ensure that a partial ;; request won't be left after aborts (e.g. control-abort on a lispm). #+cmu (ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) (defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests) ;;; This is here instead of in bufmac so that with-display can be ;;; compiled without macros and bufmac being loaded. (defmacro with-buffer ((buffer &key timeout inline) &body body &environment env) ;; This macro is for use in a multi-process environment. It provides ;; exclusive access to the local buffer object for request generation and ;; reply processing. `(macrolet ((with-buffer ((buffer &key timeout) &body body) ;; Speedup hack for lexically nested with-buffers `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-buffer-body. () ,@body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-buffer-body.)) (with-buffer-function ,buffer ,timeout #'.with-buffer-body.)) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(let (,@(unless (eq buf buffer) `((,buf ,buffer)))) ,@(unless (eq buf buffer) `((declare (type buffer ,buf)))) ,(declare-bufmac) (when (buffer-dead ,buf) (x-error 'closed-display :display ,buf)) (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))))) (defun with-buffer-function (buffer timeout function) (declare (type display buffer) (type (or null number) timeout) (type function function) #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: This is probably more a bug in SBCL (logged as ;; bug #243) (ignorable timeout) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (with-buffer (buffer :timeout timeout :inline t) (funcall function))) ;;; The following are here instead of in bufmac so that event-case can ;;; be compiled without macros and bufmac being loaded. (defmacro read-card8 (byte-index) `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int8 (byte-index) `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card16 (byte-index) #+clx-overlapping-arrays `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int16 (byte-index) #+clx-overlapping-arrays `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card32 (byte-index) #+clx-overlapping-arrays `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-int32 (byte-index) #+clx-overlapping-arrays `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro read-card29 (byte-index) #+clx-overlapping-arrays `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro event-code (reply-buffer) ;; The reply-buffer structure is used for events. ;; The size slot is used for the event code. `(reply-size ,reply-buffer)) (defmacro reading-event ((event &rest options) &body body) (declare (arglist (buffer &key sizes) &body body)) ;; BODY may contain calls to (READ32 &optional index) etc. ;; These calls will read from the input buffer at byte ;; offset INDEX. If INDEX is not supplied, then the next ;; word, half-word or byte is returned. `(with-buffer-input (,event ,@options) ,@body)) (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index) &body body) (unless (listp sizes) (setq sizes (list sizes))) ;; 160 is a special hack for client-message-events (when (set-difference sizes '(0 8 16 32 160 256)) (error "Illegal sizes in ~a" sizes)) `(let ((%reply-buffer ,reply-buffer) ,@(and display `((%buffer ,display)))) (declare (type reply-buffer %reply-buffer) ,@(and display '((type display %buffer)))) ,(declare-bufmac) ,@(and display '(%buffer)) (let* ((buffer-boffset (the array-index ,(or index 0))) #-clx-overlapping-arrays (buffer-bbuf (reply-ibuf8 %reply-buffer)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) `((buffer-bbuf (reply-ibuf8 %reply-buffer)))) (when (or (member 16 sizes) (member 160 sizes)) `((buffer-woffset (index-ash buffer-boffset -1)) (buffer-wbuf (reply-ibuf16 %reply-buffer)))) (when (member 32 sizes) `((buffer-loffset (index-ash buffer-boffset -2)) (buffer-lbuf (reply-ibuf32 %reply-buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '((declare (type buffer-bytes buffer-bbuf)))) (when (member 16 sizes) '((declare (type array-index buffer-woffset)) (declare (type buffer-words buffer-wbuf)))) (when (member 32 sizes) '((declare (type array-index buffer-loffset)) (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '(buffer-bbuf)) (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) ,@body) #-clx-overlapping-arrays ,@body))) (defun make-buffer (output-size constructor &rest options) (declare (dynamic-extent options)) ;; Output-Size is the output-buffer size in bytes. (let ((byte-output (make-array output-size :element-type 'card8 :initial-element 0))) (apply constructor :size output-size :obuf8 byte-output #+clx-overlapping-arrays :obuf16 #+clx-overlapping-arrays (make-array (index-ash output-size -1) :element-type 'overlap16 :displaced-to byte-output) #+clx-overlapping-arrays :obuf32 #+clx-overlapping-arrays (make-array (index-ash output-size -2) :element-type 'overlap32 :displaced-to byte-output) options))) (defun make-reply-buffer (size) ;; Size is the buffer size in bytes (let ((byte-input (make-array size :element-type 'card8 :initial-element 0))) (make-reply-buffer-internal :size size :ibuf8 byte-input #+clx-overlapping-arrays :ibuf16 #+clx-overlapping-arrays (make-array (index-ash size -1) :element-type 'overlap16 :displaced-to byte-input) #+clx-overlapping-arrays :ibuf32 #+clx-overlapping-arrays (make-array (index-ash size -2) :element-type 'overlap32 :displaced-to byte-input)))) (defun buffer-ensure-size (buffer size) (declare (type buffer buffer) (type array-index size)) (when (index> size (buffer-size buffer)) (with-buffer (buffer) (buffer-flush buffer) (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size)))) (new-buffer (make-array new-buffer-size :element-type 'card8 :initial-element 0))) (setf (buffer-obuf8 buffer) new-buffer) #+clx-overlapping-arrays (setf (buffer-obuf16 buffer) (make-array (index-ash new-buffer-size -1) :element-type 'overlap16 :displaced-to new-buffer) (buffer-obuf32 buffer) (make-array (index-ash new-buffer-size -2) :element-type 'overlap32 :displaced-to new-buffer)))))) (defun buffer-pad-request (buffer pad) (declare (type buffer buffer) (type array-index pad)) (unless (index-zerop pad) (when (index> (index+ (buffer-boffset buffer) pad) (buffer-size buffer)) (buffer-flush buffer)) (incf (buffer-boffset buffer) pad) (unless (index-zerop (index-mod (buffer-boffset buffer) 4)) (buffer-flush buffer)))) (declaim (inline buffer-new-request-number)) (defun buffer-new-request-number (buffer) (declare (type buffer buffer)) (setf (buffer-request-number buffer) (ldb (byte 16 0) (1+ (buffer-request-number buffer))))) (defun with-buffer-request-function (display gc-force request-function) (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) #+clx-ansi-common-lisp (dynamic-extent request-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function)) (with-buffer (display :inline t) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) (without-aborts (funcall request-function display))) (display-invoke-after-function display)))) (defun with-buffer-request-function-nolock (display gc-force request-function) (declare (type display display) (type (or null gcontext) gc-force)) (declare (type function request-function) #+clx-ansi-common-lisp (dynamic-extent request-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function)) (multiple-value-prog1 (progn (when gc-force (force-gcontext-changes-internal gc-force)) (without-aborts (funcall request-function display))) (display-invoke-after-function display))) (defstruct (pending-command (:copier nil) (:predicate nil)) (sequence 0 :type card16) (reply-buffer nil :type (or null reply-buffer)) (process nil) (next nil #-explorer :type #-explorer (or null pending-command))) (defun with-buffer-request-and-reply-function (display multiple-reply request-function reply-function) (declare (type display display) (type generalized-boolean multiple-reply)) (declare (type function request-function reply-function) #+clx-ansi-common-lisp (dynamic-extent request-function reply-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg request-function reply-function)) (let ((pending-command nil) (reply-buffer nil)) (declare (type (or null pending-command) pending-command) (type (or null reply-buffer) reply-buffer)) (unwind-protect (progn (with-buffer (display :inline t) (setq pending-command (start-pending-command display)) (without-aborts (funcall request-function display)) (buffer-force-output display) (display-invoke-after-function display)) (cond (multiple-reply (loop (setq reply-buffer (read-reply display pending-command)) (when (funcall reply-function display reply-buffer) (return nil)) (deallocate-reply-buffer (shiftf reply-buffer nil)))) (t (setq reply-buffer (read-reply display pending-command)) (funcall reply-function display reply-buffer)))) (when reply-buffer (deallocate-reply-buffer reply-buffer)) (when pending-command (stop-pending-command display pending-command))))) ;; ;; Buffer stream operations ;; (defun buffer-write (vector buffer start end) ;; Write out VECTOR from START to END into BUFFER ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER (declare (type buffer buffer) (type array-index start end)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (wrap-buf-output (buffer) (funcall (buffer-write-function buffer) vector buffer start end)) nil) (defun buffer-flush (buffer) ;; Write the buffer contents to the server stream - doesn't force-output the stream ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER (declare (type buffer buffer)) (unless (buffer-flush-inhibit buffer) (let ((boffset (buffer-boffset buffer))) (declare (type array-index boffset)) (when (index-plusp boffset) (buffer-write (buffer-obuf8 buffer) buffer 0 boffset) (setf (buffer-boffset buffer) 0) (setf (buffer-last-request buffer) nil)))) nil) (defmacro with-buffer-flush-inhibited ((buffer) &body body) (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.))) `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer))) (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf))) (unwind-protect (progn (setf (buffer-flush-inhibit ,buf) t) ,@body) (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.))))) (defun buffer-force-output (buffer) ;; Output is normally buffered, this forces any buffered output to the server. (declare (type buffer buffer)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (buffer-flush buffer) (wrap-buf-output (buffer) (without-aborts (funcall (buffer-force-output-function buffer) buffer))) nil) (defun close-buffer (buffer &key abort) ;; Close the host connection in BUFFER (declare (type buffer buffer)) (unless (null (buffer-output-stream buffer)) (wrap-buf-output (buffer) (funcall (buffer-close-function buffer) buffer :abort abort)) (setf (buffer-dead buffer) t) ;; Zap pointers to the streams, to ensure they're GC'd (setf (buffer-output-stream buffer) nil) (setf (buffer-input-stream buffer) nil) ) nil) (defun buffer-input (buffer vector start end &optional timeout) ;; Read into VECTOR from the buffer stream ;; Timeout, when non-nil, is in seconds ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) (type vector vector) (type array-index start end) (type (or null number) timeout)) (declare (clx-values eof-p)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (unless (= start end) (let ((result (wrap-buf-input (buffer) (funcall (buffer-input-function buffer) buffer vector start end timeout)))) (unless (or (null result) (eq result :timeout)) (close-buffer buffer)) result))) (defun buffer-input-wait (buffer timeout) ;; Timeout, when non-nil, is in seconds ;; Returns non-nil if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type buffer buffer) (type (or null number) timeout)) (declare (clx-values timeout)) (when (buffer-dead buffer) (x-error 'closed-display :display buffer)) (let ((result (wrap-buf-input (buffer) (funcall (buffer-input-wait-function buffer) buffer timeout)))) (unless (or (null result) (eq result :timeout)) (close-buffer buffer)) result)) (defun buffer-listen (buffer) ;; Returns T if there is input available for the buffer. This should never ;; block, so it can be called from the scheduler. (declare (type buffer buffer)) (declare (clx-values input-available)) (or (not (null (buffer-dead buffer))) (wrap-buf-input (buffer) (funcall (buffer-listen-function buffer) buffer)))) ;;; Reading sequences of strings ;;; a list of pascal-strings with card8 lengths, no padding in between ;;; can't use read-sequence-char (defun read-sequence-string (buffer-bbuf length nitems result-type &optional (buffer-boffset 0)) (declare (type buffer-bytes buffer-bbuf) (type array-index length nitems buffer-boffset)) length (with-vector (buffer-bbuf buffer-bytes) (let ((result (make-sequence result-type nitems))) (do* ((index 0 (index+ index 1 string-length)) (count 0 (index1+ count)) (string-length 0) (string "")) ((index>= count nitems) result) (declare (type array-index index count string-length) (type string string)) (setq string-length (read-card8 index) string (make-sequence 'string string-length)) (do ((i (index1+ index) (index1+ i)) (j 0 (index1+ j))) ((index>= j string-length) (setf (elt result count) string)) (declare (type array-index i j)) (setf (aref string j) (card8->char (read-card8 i)))))))) ;;; Reading sequences of chars (defmacro define-transformed-sequence-reader (name totype transformer reader) (let ((ntrans (gensym))) `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) (declare (type reply-buffer reply-buffer) (type t result-type) (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,totype) t)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform (flet ((,ntrans (v) (funcall transform (,transformer v)))) #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) (,reader reply-buffer result-type nitems #',ntrans data start index)) (,reader reply-buffer result-type nitems #',transformer data start index))))) (define-transformed-sequence-reader read-sequence-char character card8->char read-sequence-card8) ;;; Reading sequences of card8's (defmacro define-list-readers ((name tname) type size step reader) `(progn (defun ,name (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type list data)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) (index 0 (index+ index ,step))) ((index-zerop j)) (declare (type array-index index j) (type list list)) (setf (car list) (,reader index))))) (defun ,tname (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type list data) (type (function (,type) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-buffer-input (reply-buffer :sizes (,size) :index index) (do* ((j nitems (index- j 1)) (list (nthcdr start data) (cdr list)) (index 0 (index+ index ,step))) ((index-zerop j)) (declare (type array-index index j) (type list list)) (setf (car list) (funcall transform (,reader index)))))))) (define-list-readers (read-list-card8 read-list-card8-with-transform) card8 8 1 read-card8) #-lispm (defun read-simple-array-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card8 (*)) data)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8)) (buffer-replace data buffer-bbuf start (index+ start nitems) index)))) #-lispm (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card8 (*)) data)) (declare (type (function (card8) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card8 (funcall transform (read-card8 index)))))))) (defun read-vector-card8 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card8 index)))))) (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card8) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (8) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 1))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card8 index))))))) (defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec)) `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0)) (declare (type reply-buffer reply-buffer) (type t result-type) (type array-index nitems start index) (type (or null sequence) data) (type (or null (function (,type) t)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (let ((result (or data (make-sequence result-type nitems)))) (typecase result (list (if transform (,tlist reply-buffer nitems result transform start index) (,list reply-buffer nitems result start index))) #-lispm ((simple-array ,type (*)) (if transform (,tsa reply-buffer nitems result transform start index) (,sa reply-buffer nitems result start index))) ;; FIXME: general sequences (t (if transform (,tvec reply-buffer nitems result transform start index) (,vec reply-buffer nitems result start index)))) result))) (define-sequence-reader read-sequence-card8 card8 (read-list-card8 read-list-card8-with-transform) (read-simple-array-card8 read-simple-array-card8-with-transform) (read-vector-card8 read-vector-card8-with-transform)) (define-transformed-sequence-reader read-sequence-int8 int8 card8->int8 read-sequence-card8) ;;; Reading sequences of card16's (define-list-readers (read-list-card16 read-list-card16-with-transform) card16 16 2 read-card16) #-lispm (defun read-simple-array-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card16 (read-card16 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) #-lispm (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card16 (*)) data)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card16 (funcall transform (read-card16 index)))))))) (defun read-vector-card16 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card16 index))) #+clx-overlapping-arrays (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2))))) (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card16) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (16) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 2))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card16 index))))))) (define-sequence-reader read-sequence-card16 card16 (read-list-card16 read-list-card16-with-transform) (read-simple-array-card16 read-simple-array-card16-with-transform) (read-vector-card16 read-vector-card16-with-transform)) (define-transformed-sequence-reader read-sequence-int16 int16 card16->int16 read-sequence-card16) ;;; Reading sequences of card32's (define-list-readers (read-list-card32 read-list-card32-with-transform) card32 32 4 read-card32) #-lispm (defun read-simple-array-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card32 (read-card32 index)))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) #-lispm (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type (simple-array card32 (*)) data)) (declare (type (function (card32) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (the card32 (funcall transform (read-card32 index)))))))) (defun read-vector-card32 (reply-buffer nitems data start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) #-clx-overlapping-arrays (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (read-card32 index))) #+clx-overlapping-arrays (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4))))) (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index) (declare (type reply-buffer reply-buffer) (type array-index nitems start index) (type vector data) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (card32) t) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (with-buffer-input (reply-buffer :sizes (32) :index index) (do* ((j start (index+ j 1)) (end (index+ start nitems)) (index 0 (index+ index 4))) ((index>= j end)) (declare (type array-index j end index)) (setf (aref data j) (funcall transform (read-card32 index))))))) (define-sequence-reader read-sequence-card32 card32 (read-list-card32 read-list-card32-with-transform) (read-simple-array-card32 read-simple-array-card32-with-transform) (read-vector-card32 read-vector-card32-with-transform)) (define-transformed-sequence-reader read-sequence-int32 int32 card32->int32 read-sequence-card32) ;;; Writing sequences of chars (defmacro define-transformed-sequence-writer (name fromtype transformer writer) (let ((ntrans (gensym))) `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) (declare (type buffer buffer) (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,fromtype)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (if transform (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x))))) #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans)) (,writer buffer boffset data start end #',ntrans)) (,writer buffer boffset data start end #',transformer))))) (define-transformed-sequence-writer write-sequence-char character char->card8 write-sequence-card8) ;;; Writing sequences of card8's (defmacro define-list-writers ((name tname) type step writer) `(progn (defun ,name (buffer boffset data start end) (declare (type buffer buffer) (type list data) (type array-index boffset start end)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) (do ((j 0 (index+ j ,step))) ((index>= j chunk)) (declare (type array-index j)) (,writer j (pop list))))) (defun ,tname (buffer boffset data start end transform) (declare (type buffer buffer) (type list data) (type array-index boffset start end) (type (function (t) ,type) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (writing-buffer-chunks ,type ((list (nthcdr start data))) ((type list list)) (do ((j 0 (index+ j ,step))) ((index>= j chunk)) (declare (type array-index j)) (,writer j (funcall transform (pop list)))))))) ;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8 #+ti (progn (defun write-list-card8 (buffer boffset data start end) (writing-buffer-chunks card8 ((list (nthcdr start data))) ((type list list)) (dotimes (j chunk) (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list))))) (defun write-list-card8-with-transform (buffer boffset data start end transform) (writing-buffer-chunks card8 ((list (nthcdr start data))) ((type list lst)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (pop lst))))))) #-ti (define-list-writers (write-list-card8 write-list-card8-with-transform) card8 1 write-card8) ;;; Should really write directly from data, instead of into the buffer first #-lispm (defun write-simple-array-card8 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card8 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start (index+ index chunk))) ((type array-index index)) (buffer-replace buffer-bbuf data buffer-boffset (index+ buffer-boffset chunk) index))) nil) #-lispm (defun write-simple-array-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card8 (*)) data) (type array-index boffset start end)) (declare (type (function (card8) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card8 (*))) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card8 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (aref data index)) (setq index (index+ index 1))))) nil) (defun write-vector-card8-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end)) (declare (type (function (t) card8) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card8 ((index start)) ((type array-index index)) (dotimes (j chunk) (declare (type array-index j)) (write-card8 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec)) `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform) (declare (type buffer buffer) (type sequence data) (type array-index boffset start end) (type (or null (function (t) ,type)) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (typecase data (list (if transform (,tlist buffer boffset data start end transform) (,list buffer boffset data start end))) #-lispm ((simple-array ,type (*)) (if transform (,tsa buffer boffset data start end transform) (,sa buffer boffset data start end))) (t ; FIXME: general sequences (if transform (,tvec buffer boffset data start end transform) (,vec buffer boffset data start end)))))) (define-sequence-writer write-sequence-card8 card8 (write-list-card8 write-list-card8-with-transform) (write-simple-array-card8 write-simple-array-card8-with-transform) (write-vector-card8 write-vector-card8-with-transform)) (define-transformed-sequence-writer write-sequence-int8 int8 int8->card8 write-sequence-card8) ;;; Writing sequences of card16's (define-list-writers (write-list-card16 write-list-card16-with-transform) card16 2 write-card16) #-lispm (defun write-simple-array-card16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card16 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-card16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-card16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card16 card16 (write-list-card16 write-list-card16-with-transform) (write-simple-array-card16 write-simple-array-card16-with-transform) (write-vector-card16 write-vector-card16-with-transform)) ;;; Writing sequences of int16's (define-list-writers (write-list-int16 write-list-int16-with-transform) int16 2 write-int16) #-lispm (defun write-simple-array-int16 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array int16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array int16 (*)) data) (type array-index boffset start end)) (declare (type (function (int16) int16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array int16 (*))) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-int16 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 2))) (buffer-replace buffer-wbuf data buffer-woffset (index+ buffer-woffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-int16-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) int16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks int16 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of int16's big (do ((j 0 (index+ j 2))) ((index>= j chunk)) (declare (type array-index j)) (write-int16 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-int16 int16 (write-list-int16 write-list-int16-with-transform) (write-simple-array-int16 write-simple-array-int16-with-transform) (write-vector-int16 write-vector-int16-with-transform)) ;;; Writing sequences of card32's (define-list-writers (write-list-card32 write-list-card32-with-transform) card32 4 write-card32) #-lispm (defun write-simple-array-card32 (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card32 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) (buffer-replace buffer-lbuf data buffer-loffset (index+ buffer-loffset length) index) (setq index (index+ index length))))) nil) #-lispm (defun write-simple-array-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card32 (*)) data) (type array-index boffset start end)) (declare (type (function (card32) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card32 (*))) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-card32 (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (aref data index)) (setq index (index+ index 1))) ;; overlapping case (let ((length (floor chunk 4))) (buffer-replace buffer-lbuf data buffer-loffset (index+ buffer-loffset length) index) (setq index (index+ index length))))) nil) (defun write-vector-card32-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card32) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card32 ((index start)) ((type array-index index)) ;; Depends upon the chunks being an even multiple of card32's big (do ((j 0 (index+ j 4))) ((index>= j chunk)) (declare (type array-index j)) (write-card32 j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-card32 card32 (write-list-card32 write-list-card32-with-transform) (write-simple-array-card32 write-simple-array-card32-with-transform) (write-vector-card32 write-vector-card32-with-transform)) (define-transformed-sequence-writer write-sequence-int32 int32 int32->card32 write-sequence-card32) (defun read-bitvector256 (buffer-bbuf boffset data) (declare (type buffer-bytes buffer-bbuf) (type array-index boffset) (type (or null (simple-bit-vector 256)) data)) (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0)))) (declare (type (simple-bit-vector 256) result)) (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte (j 8 (index+ j 8))) ((index>= j 256)) (declare (type array-index i j)) (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1)) (k j (index+ k 1))) ((zerop byte) (when data ;; Clear uninitialized bits in data (do ((end (index+ j 8))) ((index= k end)) (declare (type array-index end)) (setf (aref result k) 0) (index-incf k)))) (declare (type array-index k) (type card8 byte)) (setf (aref result k) (the bit (logand byte 1))))) result)) (defun write-bitvector256 (buffer boffset map) (declare (type buffer buffer) (type array-index boffset) (type (simple-array bit (*)) map)) (with-buffer-output (buffer :index boffset :sizes 8) (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte (j 8 (index+ j 8))) ((index>= j 256)) (declare (type array-index i j)) (do ((byte 0) (bit (index+ j 7) (index- bit 1))) ((index< bit j) (aset-card8 byte buffer-bbuf i)) (declare (type array-index bit) (type card8 byte)) (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit)))))))) ;;; Writing sequences of char2b's (define-list-writers (write-list-char2b write-list-char2b-with-transform) card16 2 write-char2b) #-lispm (defun write-simple-array-char2b (buffer boffset data start end) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (aref data index)) (setq index (index+ index 1))))) nil) #-lispm (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type (simple-array card16 (*)) data) (type array-index boffset start end)) (declare (type (function (card16) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data (simple-array card16 (*))) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (defun write-vector-char2b (buffer boffset data start end) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (aref data index)) (setq index (index+ index 1))))) nil) (defun write-vector-char2b-with-transform (buffer boffset data start end transform) (declare (type buffer buffer) (type vector data) (type array-index boffset start end) (optimize #+cmu(ext:inhibit-warnings 3))) (declare (type (function (t) card16) transform) #+clx-ansi-common-lisp (dynamic-extent transform) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform)) (with-vector (data vector) (writing-buffer-chunks card16 ((index start)) ((type array-index index)) (do ((j 0 (index+ j 2))) ((index>= j (1- chunk)) (setf chunk j)) (declare (type array-index j)) (write-char2b j (funcall transform (aref data index))) (setq index (index+ index 1))))) nil) (define-sequence-writer write-sequence-char2b card16 (write-list-char2b write-list-char2b-with-transform) (write-simple-array-char2b write-simple-array-char2b-with-transform) (write-vector-char2b write-vector-char2b-with-transform)) cmucl-21a/src/clx/bufmac.lisp000066400000000000000000000157321260377556400162740ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains macro definitions for the BUFFER object for Common-Lisp ;;; X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. (defmacro write-card8 (byte-index item) `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int8 (byte-index item) `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card16 (byte-index item) #+clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-card16 (the card16 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int16 (byte-index item) #+clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1))) #-clx-overlapping-arrays `(aset-int16 (the int16 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card32 (byte-index item) #+clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card32 (the card32 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-int32 (byte-index item) #+clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-int32 (the int32 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) (defmacro write-card29 (byte-index item) #+clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2))) #-clx-overlapping-arrays `(aset-card29 (the card29 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries ;; and always are written high-order byte first. (defmacro write-char2b (byte-index item) ;; It is impossible to do an overlapping write, so only nonoverlapping here. `(let ((%item ,item) (%byte-index (index+ buffer-boffset ,byte-index))) (declare (type card16 %item) (type array-index %byte-index)) (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) (defmacro set-buffer-offset (value &environment env) env `(let ((.boffset. ,value)) (declare (type array-index .boffset.)) (setq buffer-boffset .boffset.) #+clx-overlapping-arrays ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) `((setq buffer-woffset (index-ash .boffset. -1)))) #+clx-overlapping-arrays ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) `((setq buffer-loffset (index-ash .boffset. -2)))) #+clx-overlapping-arrays .boffset.)) (defmacro advance-buffer-offset (value) `(set-buffer-offset (index+ buffer-boffset ,value))) (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) (unless (listp sizes) (setq sizes (list sizes))) `(let ((%buffer ,buffer)) (declare (type display %buffer)) ,(declare-bufmac) ,(when length `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) (buffer-flush %buffer))) (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) #-clx-overlapping-arrays (buffer-bbuf (buffer-obuf8 %buffer)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) `((buffer-bbuf (buffer-obuf8 %buffer)))) (when (or (member 16 sizes) (member 160 sizes)) `((buffer-woffset (index-ash buffer-boffset -1)) (buffer-wbuf (buffer-obuf16 %buffer)))) (when (member 32 sizes) `((buffer-loffset (index-ash buffer-boffset -2)) (buffer-lbuf (buffer-obuf32 %buffer)))))) (declare (type array-index buffer-boffset)) #-clx-overlapping-arrays (declare (type buffer-bytes buffer-bbuf)) #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '((declare (type buffer-bytes buffer-bbuf)))) (when (member 16 sizes) '((declare (type array-index buffer-woffset)) (declare (type buffer-words buffer-wbuf)))) (when (member 32 sizes) '((declare (type array-index buffer-loffset)) (declare (type buffer-longs buffer-lbuf))))) buffer-boffset #-clx-overlapping-arrays buffer-bbuf #+clx-overlapping-arrays ,@(append (when (member 8 sizes) '(buffer-bbuf)) (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) #+clx-overlapping-arrays (macrolet ((%buffer-sizes () ',sizes)) ,@body) #-clx-overlapping-arrays ,@body))) ;;; This macro is just used internally in buffer (defmacro writing-buffer-chunks (type args decls &body body) (when (> (length body) 2) (error "writing-buffer-chunks called with too many forms")) (let* ((size (* 8 (index-increment type))) (form #-clx-overlapping-arrays (first body) #+clx-overlapping-arrays ; XXX type dependencies (or (second body) (first body)))) `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) ;; Loop filling the buffer (do* (,@args ;; Number of bytes needed to output (len ,(if (= size 8) `(index- end start) `(index-ash (index- end start) ,(truncate size 16))) (index- len chunk)) ;; Number of bytes available in buffer (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) (index-min len (index- (buffer-size buffer) buffer-boffset)))) ((not (index-plusp len))) (declare ,@decls (type array-index len chunk)) ,form (index-incf buffer-boffset chunk) ;; Flush the buffer (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) (setf (buffer-boffset buffer) buffer-boffset) (buffer-flush buffer) (setq buffer-boffset (buffer-boffset buffer)) #+clx-overlapping-arrays ,(case size (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) (setf (buffer-boffset buffer) (lround buffer-boffset))))) cmucl-21a/src/clx/build-clx.lisp000066400000000000000000000017461260377556400167220ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- #+cmu (ext:file-comment "$Id: build-clx.lisp,v 1.5 2009/06/17 18:22:45 rtoy Rel $") ;;; Load this file if you want to compile CLX in its entirety. (proclaim '(optimize (speed 3) (safety 1) (space 1) (compilation-speed 0))) ;;; Hide CLOS from CLX, so objects stay implemented as structures. ;;; #|| (when (find-package "CLOS") (rename-package (find-package "CLOS") "NO-CLOS-HERE")) (when (find-package "PCL") (rename-package (find-package "PCL") "NO-PCL-HERE")) (when (find-package "SB-PCL") (rename-package (find-package "SB-PCL") "NO-SB-PCL-HERE")) ||# (when (find-package "XLIB") (delete-package "XLIB")) (unless (find-package "XLIB") (make-package "XLIB" :use '("COMMON-LISP"))) #-sbcl (compile-file "clx:defsystem.lisp" :error-file nil :load t) #+sbcl (progn (compile-file "clx:defsystem.lisp") (load "clx:defsystem")) (with-compilation-unit () (#+cmu xlib:compile-clx #-cmu compile-clx (pathname "CLX:"))) cmucl-21a/src/clx/clx-module.lisp000066400000000000000000000003701260377556400171000ustar00rootroot00000000000000;;;(in-package :xlib) ;;;(common-lisp:use-package (list :common-lisp)) #+cmu (ext:file-comment "$Id: clx-module.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (provide :clx) (load "clx:defsystem.lisp") (load-clx (translate-logical-pathname "CLX:")) cmucl-21a/src/clx/clx.asd000066400000000000000000000176201260377556400154230ustar00rootroot00000000000000;;; -*- Lisp -*- mode ;;; Original copyright message from defsystem.lisp: ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. ;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" ;;; without express or implied warranty. ;;; ;;; Franz Incorporated provides this software "as is" without express ;;; or implied warranty. (defpackage :clx-system (:use :cl :asdf)) (in-package :clx-system) (pushnew :clx-ansi-common-lisp *features*) (defclass clx-source-file (cl-source-file) ()) (defclass xrender-source-file (clx-source-file) ()) ;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of ;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-) (defclass example-source-file (cl-source-file) ()) (defclass legacy-file (static-file) ()) (defsystem CLX :depends-on (#+sbcl sb-bsd-sockets) :version "0.7.2" :serial t :default-component-class clx-source-file :components ((:file "package") (:file "depdefs") (:file "clx") #-(or openmcl allegro) (:file "dependent") #+openmcl (:file "dep-openmcl") #+allegro (:file "dep-allegro") (:file "macros") (:file "bufmac") (:file "buffer") (:file "display") (:file "gcontext") (:file "input") (:file "requests") (:file "fonts") (:file "graphics") (:file "text") (:file "attributes") (:file "translate") (:file "keysyms") (:file "manager") (:file "image") (:file "resource") #+allegro (:file "excldep" :pathname "excldep.lisp") (:module extensions :pathname #.(make-pathname :directory '(:relative)) :components ((:file "shape") (:file "big-requests") (:file "xvidmode") (:xrender-source-file "xrender") (:file "glx") (:file "gl" :depends-on ("glx")) (:file "dpms") (:file "xtest") (:file "screensaver") (:file "xinerama"))) (:module demo :default-component-class example-source-file :components ((:file "bezier") ;; KLUDGE: this requires "bezier" for proper operation, ;; but we don't declare that dependency here, because ;; asdf doesn't load example files anyway. (:file "beziertest") (:file "clclock") (:file "clipboard") (:file "clx-demos") (:file "gl-test") ;; FIXME: compiling this generates 30-odd spurious code ;; deletion notes. Find out why, and either fix or ;; workaround the problem. (:file "mandel") (:file "menu") (:file "zoid"))) (:module test :default-component-class example-source-file :components ((:file "image") ;; KLUDGE: again, this depends on "zoid" (:file "trapezoid"))) (:static-file "NEWS") (:static-file "CHANGES") (:static-file "README") (:static-file "README-R5") (:legacy-file "exclMakefile") (:legacy-file "exclREADME") (:legacy-file "exclcmac" :pathname "exclcmac.lisp") (:legacy-file "excldepc" :pathname "excldep.c") (:legacy-file "sockcl" :pathname "sockcl.lisp") (:legacy-file "socket" :pathname "socket.c") (:legacy-file "defsystem" :pathname "defsystem.lisp") (:legacy-file "provide" :pathname "provide.lisp") (:legacy-file "cmudep" :pathname "cmudep.lisp") (:module manual ;; TODO: teach asdf how to process texinfo files :components ((:static-file "clx.texinfo"))) (:module debug :default-component-class legacy-file :components ((:file "debug" :pathname "debug.lisp") (:file "describe" :pathname "describe.lisp") (:file "event-test" :pathname "event-test.lisp") (:file "keytrans" :pathname "keytrans.lisp") (:file "trace" :pathname "trace.lisp") (:file "util" :pathname "util.lisp"))))) (defmethod perform ((o load-op) (f example-source-file)) ;; do nothing. We want to compile them when CLX is compiled, but ;; not load them when CLX is loaded. t) #+sbcl (defmethod perform :around ((o compile-op) (f xrender-source-file)) ;; RENDER would appear to be an inherently slow protocol; further, ;; it's not set in stone, and consequently we care less about speed ;; than we do about correctness. (handler-bind ((sb-ext:compiler-note #'muffle-warning)) (call-next-method))) #+sbcl (defmethod perform :around ((o compile-op) (f clx-source-file)) ;; our CLX library should compile without WARNINGs, and ideally ;; without STYLE-WARNINGs. Since it currently does, let's enforce ;; it here so that we can catch regressions easily. (let ((on-warnings (operation-on-warnings o)) (on-failure (operation-on-failure o))) (unwind-protect (progn (setf (operation-on-warnings o) :error (operation-on-failure o) :error) ;; a variety of accessors, such as AREF-CARD32, are not ;; declared INLINE. Without this (non-ANSI) ;; static-type-inference behaviour, SBCL emits an extra 100 ;; optimization notes (roughly one fifth of all of the ;; notes emitted). Since the internals are unlikely to ;; change much, and certainly the internals should stay in ;; sync, enabling this extension is a win. (Note that the ;; use of this does not imply that applications using CLX ;; calls that expand into calls to these accessors will be ;; optimized in the same way). (let ((sb-ext:*derive-function-types* t) (sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c)) (sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext))) ;; deeply unportable stuff, this. I will be shot. We ;; want to enable the dynamic-extent declarations in CLX. (when (and sadx (sb-c::policy-quality-name-p sadx)) ;; no way of setting it back short of yet more yukky stuff (proclaim `(optimize (,sadx 3)))) (if sadx-var (progv (list sadx-var) (list t) (call-next-method)) (call-next-method)))) (setf (operation-on-warnings o) on-warnings (operation-on-failure o) on-failure)))) #+sbcl (defmethod perform :around (o (f clx-source-file)) ;; SBCL signals an error if DEFCONSTANT is asked to redefine a ;; constant unEQLly. For CLX's purposes, however, we are defining ;; structured constants (lists and arrays) not for EQLity, but for ;; the purposes of constant-folding operations such as (MEMBER FOO ;; +BAR+), so it is safe to abort the redefinition provided the ;; structured data is sufficiently equal. (handler-bind ((sb-ext:defconstant-uneql (lambda (c) ;; KLUDGE: this really means "don't warn me about ;; efficiency of generic array access, please" (declare (optimize (sb-ext:inhibit-warnings 3))) (let ((old (sb-ext:defconstant-uneql-old-value c)) (new (sb-ext:defconstant-uneql-new-value c))) (typecase old (list (when (equal old new) (abort c))) (string (when (and (typep new 'string) (string= old new)) (abort c))) (simple-vector (when (and (typep new 'simple-vector) (= (length old) (length new)) (every #'eql old new)) (abort c))) (array (when (and (typep new 'array) (equal (array-dimensions old) (array-dimensions new)) (equal (array-element-type old) (array-element-type new)) (dotimes (i (array-total-size old) t) (unless (eql (row-major-aref old i) (row-major-aref new i)) (return nil)))) (abort c)))))))) (call-next-method))) cmucl-21a/src/clx/clx.lisp000066400000000000000000001056621260377556400156270ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;; Primary Interface Author: ;; Robert W. Scheifler ;; MIT Laboratory for Computer Science ;; 545 Technology Square, Room 418 ;; Cambridge, MA 02139 ;; rws@zermatt.lcs.mit.edu ;; Design Contributors: ;; Dan Cerys, Texas Instruments ;; Scott Fahlman, CMU ;; Charles Hornig, Symbolics ;; John Irwin, Franz ;; Kerry Kimbrough, Texas Instruments ;; Chris Lindblad, MIT ;; Rob MacLachlan, CMU ;; Mike McMahon, Symbolics ;; David Moon, Symbolics ;; LaMott Oren, Texas Instruments ;; Daniel Weinreb, Symbolics ;; John Wroclawski, MIT ;; Richard Zippel, Symbolics ;; Primary Implementation Author: ;; LaMott Oren, Texas Instruments ;; Implementation Contributors: ;; Charles Hornig, Symbolics ;; John Irwin, Franz ;; Chris Lindblad, MIT ;; Robert Scheifler, MIT ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 04/07/87 R.Scheifler Created code stubs ;;; 04/08/87 L.Oren Started Implementation ;;; 05/11/87 L.Oren Included draft 3 revisions ;;; 07/07/87 L.Oren Untested alpha release to MIT ;;; 07/17/87 L.Oren Alpha release ;;; 08/**/87 C.Lindblad Rewrite of buffer code ;;; 08/**/87 et al Various random bug fixes ;;; 08/**/87 R.Scheifler General syntactic and portability cleanups ;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing ;;; 09/02/87 L.Oren Change events from resource-ids to objects ;;; 12/24/87 R.Budzianowski KCL support ;;; 12/**/87 J.Irwin ExCL 2.0 support ;;; 01/20/88 L.Oren Add server extension mechanisms ;;; 01/20/88 L.Oren Only force output when blocking on input ;;; 01/20/88 L.Oren Uniform support for :event-window on events ;;; 01/28/88 L.Oren Add window manager property functions ;;; 01/28/88 L.Oren Add character translation facility ;;; 02/**/87 J.Irwin Allegro 2.2 support ;;; This is considered a somewhat changeable interface. Discussion of better ;;; integration with CLOS, support for user-specified subclassess of basic ;;; objects, and the additional functionality to match the C Xlib is still in ;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu. #+cmu (ext:file-comment "$Id: clx.lisp,v 1.16 2009/06/17 18:22:45 rtoy Rel $") ;; Note: all of the following is in the package XLIB. (in-package :xlib) (pushnew :clx *features*) (pushnew :xlib *features*) (defparameter *version* "Telent CLX 0.7.3 + CMUCL mods, based on MIT R5.02") (pushnew :clx-mit-r4 *features*) (pushnew :clx-mit-r5 *features*) (defparameter *protocol-major-version* 11.) (defparameter *protocol-minor-version* 0) (defparameter *x-tcp-port* 6000) ;; add display number ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of ;; the relationships should be fairly obvious. We have no intention of writing yet ;; another moby document for this interface. ;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. ;; These types are defined solely by a functional interface; we do not specify ;; whether they are implemented as structures or flavors or ... Although functions ;; below are written using DEFUN, this is not an implementation requirement (although ;; it is a requirement that they be functions as opposed to macros or special forms). ;; It is unclear whether with-slots in the Common Lisp Object System must work on ;; them. ;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as ;; compound objects, rather than as integer resource-ids. This allows applications ;; to deal with multiple displays without having an explicit display argument in the ;; most common functions. Every function uses the display object indicated by the ;; first argument that is or contains a display; it is an error if arguments contain ;; different displays, and predictable results are not guaranteed. ;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following ;; five functions: ;(defun make- (display resource-id) ; ;; This function should almost never be called by applications, except in handling ; ;; events. To minimize consing in some implementations, this may use a cache in ; ;; the display. Make-gcontext creates with :cache-p nil. Make-font creates with ; ;; cache-p true. ; (declare (type display display) ; (type integer resource-id) ; (clx-values ))) ;(defun -display () ; (declare (type ) ; (clx-values display))) ;(defun -id () ; (declare (type ) ; (clx-values integer))) ;(defun -equal (-1 -2) ; (declare (type -1 -2))) ;(defun -p (-1 -2) ; (declare (type -1 -2) ; (clx-values boolean))) (deftype generalized-boolean () 't) ; (or null (not null)) (deftype card32 () '(unsigned-byte 32)) (deftype card29 () '(unsigned-byte 29)) (deftype card24 () '(unsigned-byte 24)) (deftype int32 () '(signed-byte 32)) (deftype card16 () '(unsigned-byte 16)) (deftype int16 () '(signed-byte 16)) (deftype card8 () '(unsigned-byte 8)) (deftype int8 () '(signed-byte 8)) (deftype card4 () '(unsigned-byte 4)) #-clx-ansi-common-lisp (deftype real (&optional (min '*) (max '*)) (labels ((convert (limit floatp) (typecase limit (number (if floatp (float limit 0s0) (rational limit))) (list (map 'list #'convert limit)) (otherwise limit)))) `(or (float ,(convert min t) ,(convert max t)) (rational ,(convert min nil) ,(convert max nil))))) #-clx-ansi-common-lisp (deftype base-char () 'string-char) ; Note that we are explicitly using a different rgb representation than what ; is actually transmitted in the protocol. (deftype rgb-val () '(real 0 1)) ; Note that we are explicitly using a different angle representation than what ; is actually transmitted in the protocol. (deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) (deftype mask32 () 'card32) (deftype mask16 () 'card16) (deftype pixel () '(unsigned-byte 32)) (deftype image-depth () '(integer 0 32)) (deftype resource-id () 'card29) (deftype keysym () 'card32) ; The following functions are provided by color objects: ; The intention is that IHS and YIQ and CYM interfaces will also exist. ; Note that we are explicitly using a different spectrum representation ; than what is actually transmitted in the protocol. (def-clx-class (color (:constructor make-color-internal (red green blue)) (:copier nil) (:print-function print-color)) (red 0.0 :type rgb-val) (green 0.0 :type rgb-val) (blue 0.0 :type rgb-val)) (defun print-color (color stream depth) (declare (type color color) (ignore depth)) (print-unreadable-object (color stream :type t) (prin1 (color-red color) stream) (write-string " " stream) (prin1 (color-green color) stream) (write-string " " stream) (prin1 (color-blue color) stream))) (defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys) (declare (type rgb-val red green blue)) (declare (clx-values color)) (make-color-internal red green blue)) (defun color-rgb (color) (declare (type color color)) (declare (clx-values red green blue)) (values (color-red color) (color-green color) (color-blue color))) (def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format)) (unit 8 :type (member 8 16 32)) (pad 8 :type (member 8 16 32)) (lsb-first-p nil :type generalized-boolean)) (defun print-bitmap-format (bitmap-format stream depth) (declare (type bitmap-format bitmap-format) (ignore depth)) (print-unreadable-object (bitmap-format stream :type t) (format stream "unit ~D pad ~D ~:[M~;L~]SB first" (bitmap-format-unit bitmap-format) (bitmap-format-pad bitmap-format) (bitmap-format-lsb-first-p bitmap-format)))) (def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format)) (depth 0 :type image-depth) (bits-per-pixel 8 :type (member 1 4 8 12 16 24 32)) (scanline-pad 8 :type (member 8 16 32))) (defun print-pixmap-format (pixmap-format stream depth) (declare (type pixmap-format pixmap-format) (ignore depth)) (print-unreadable-object (pixmap-format stream :type t) (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D" (pixmap-format-depth pixmap-format) (pixmap-format-bits-per-pixel pixmap-format) (pixmap-format-scanline-pad pixmap-format)))) (defparameter *atom-cache-size* 200) (defparameter *resource-id-map-size* 500) (def-clx-class (display (:include buffer) (:constructor make-display-internal) (:print-function print-display) (:copier nil)) (host) ; Server Host (display 0 :type integer) ; Display number on host (after-function nil) ; Function to call after every request (event-lock (make-process-lock "CLX Event Lock")) ; with-event-queue lock (event-queue-lock (make-process-lock "CLX Event Queue Lock")) ; new-events/event-queue lock (event-queue-tail ; last event in the event queue nil :type (or null reply-buffer)) (event-queue-head ; Threaded queue of events nil :type (or null reply-buffer)) (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*) :type hash-table) ; Hash table relating atoms keywords ; to atom id's (font-cache nil) ; list of font (protocol-major-version 0 :type card16) ; Major version of server's X protocol (protocol-minor-version 0 :type card16) ; minor version of servers X protocol (vendor-name "" :type string) ; vendor of the server hardware (resource-id-base 0 :type resource-id) ; resouce ID base (resource-id-mask 0 :type resource-id) ; resource ID mask bits (resource-id-byte nil) ; resource ID mask field (used with DPB & LDB) (resource-id-count 0 :type resource-id) ; resource ID mask count ; (used for allocating ID's) (resource-id-map (make-hash-table :test (resource-id-map-test) :size *resource-id-map-size*) :type hash-table) ; hash table maps resource-id's to ; objects (used in lookup functions) (xid 'resourcealloc) ; allocator function (byte-order #+clx-little-endian :lsbfirst ; connection byte order #-clx-little-endian :msbfirst) (release-number 0 :type card32) ; release of the server (max-request-length 0 :type card16) ; maximum number 32 bit words in request (default-screen) ; default screen for operations (roots nil :type list) ; List of screens (motion-buffer-size 0 :type card32) ; size of motion buffer (xdefaults) ; contents of defaults from server (image-lsb-first-p nil :type generalized-boolean) (bitmap-format (make-bitmap-format) ; Screen image info :type bitmap-format) (pixmap-formats nil :type sequence) ; list of pixmap formats (min-keycode 0 :type card8) ; minimum key-code (max-keycode 0 :type card8) ; maximum key-code (error-handler 'default-error-handler) ; Error handler function (close-down-mode :destroy) ; Close down mode saved by Set-Close-Down-Mode (authorization-name "" :type string) (authorization-data "" :type (or (array (unsigned-byte 8)) string)) (last-width nil :type (or null card29)) ; Accumulated width of last string (keysym-mapping nil ; Keysym mapping cached from server :type (or null (array * (* *)))) (modifier-mapping nil :type list) ; ALIST of (keysym . state-mask) for all modifier keysyms (keysym-translation nil :type list) ; An alist of (keysym object function) ; for display-local keysyms (extension-alist nil :type list) ; extension alist, which has elements: ; (name major-opcode first-event first-error) (event-extensions '#() :type vector) ; Vector mapping X event-codes to event keys (performance-info) ; Hook for gathering performance info (trace-history) ; Hook for debug trace (plist nil :type list) ; hook for extension to hang data ;; These slots are used to manage multi-process input. (input-in-progress nil) ; Some process reading from the stream. ; Updated with CONDITIONAL-STORE. (pending-commands nil) ; Threaded list of PENDING-COMMAND objects ; for all commands awaiting replies. ; Protected by WITH-EVENT-QUEUE-INTERNAL. (asynchronous-errors nil) ; Threaded list of REPLY-BUFFER objects ; containing error messages for commands ; which did not expect replies. ; Protected by WITH-EVENT-QUEUE-INTERNAL. (report-asynchronous-errors ; When to report asynchronous errors '(:immediately) :type list) ; The keywords that can be on this list ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING, ; and :AFTER-FINISH-OUTPUT (event-process nil) ; Process ID of process awaiting events. ; Protected by WITH-EVENT-QUEUE. (new-events nil :type (or null reply-buffer)) ; Pointer to the first new event in the ; event queue. ; Protected by WITH-EVENT-QUEUE. (current-event-symbol ; Bound with PROGV by event handling macros (list (gensym) (gensym)) :type cons) (atom-id-map (make-hash-table :test (resource-id-map-test) :size *atom-cache-size*) :type hash-table) (extended-max-request-length 0 :type card32) ) (defun print-display-name (display stream) (declare (type (or null display) display)) (cond (display #-allegro (princ (display-host display) stream) #+allegro (write-string (string (display-host display)) stream) (write-string ":" stream) (princ (display-display display) stream)) (t (write-string "(no display)" stream))) display) (defun print-display (display stream depth) (declare (type display display) (ignore depth)) (print-unreadable-object (display stream :type t) (print-display-name display stream) (write-string " (" stream) (write-string (display-vendor-name display) stream) (write-string " R" stream) (prin1 (display-release-number display) stream) (write-string ")" stream))) ;;(deftype drawable () '(or window pixmap)) (def-clx-class (drawable (:copier nil) (:print-function print-drawable)) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook ) (defun print-drawable (drawable stream depth) (declare (type drawable drawable) (ignore depth)) (print-unreadable-object (drawable stream :type t) (print-display-name (drawable-display drawable) stream) (write-string " " stream) (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream)))) (def-clx-class (window (:include drawable) (:copier nil) (:print-function print-drawable)) ) (def-clx-class (pixmap (:include drawable) (:copier nil) (:print-function print-drawable)) ) (def-clx-class (visual-info (:copier nil) (:print-function print-visual-info)) (id 0 :type resource-id) (display nil :type (or null display)) (class :static-gray :type (member :static-gray :static-color :true-color :gray-scale :pseudo-color :direct-color)) (red-mask 0 :type pixel) (green-mask 0 :type pixel) (blue-mask 0 :type pixel) (bits-per-rgb 1 :type card8) (colormap-entries 0 :type card16) (plist nil :type list) ; Extension hook ) (defun print-visual-info (visual-info stream depth) (declare (type visual-info visual-info) (ignore depth)) (print-unreadable-object (visual-info stream :type t) (prin1 (visual-info-bits-per-rgb visual-info) stream) (write-string "-bit " stream) (princ (visual-info-class visual-info) stream) (write-string " " stream) (print-display-name (visual-info-display visual-info) stream) (write-string " " stream) (prin1 (visual-info-id visual-info) stream))) (def-clx-class (colormap (:copier nil) (:print-function print-colormap)) (id 0 :type resource-id) (display nil :type (or null display)) (visual-info nil :type (or null visual-info)) ) (defun print-colormap (colormap stream depth) (declare (type colormap colormap) (ignore depth)) (print-unreadable-object (colormap stream :type t) (when (colormap-visual-info colormap) (princ (visual-info-class (colormap-visual-info colormap)) stream) (write-string " " stream)) (print-display-name (colormap-display colormap) stream) (write-string " " stream) (prin1 (colormap-id colormap) stream))) (def-clx-class (cursor (:copier nil) (:print-function print-cursor)) (id 0 :type resource-id) (display nil :type (or null display)) ) (defun print-cursor (cursor stream depth) (declare (type cursor cursor) (ignore depth)) (print-unreadable-object (cursor stream :type t) (print-display-name (cursor-display cursor) stream) (write-string " " stream) (prin1 (cursor-id cursor) stream))) ; Atoms are accepted as strings or symbols, and are always returned as keywords. ; Protocol-level integer atom ids are hidden, using a cache in the display object. (deftype xatom () '(or string symbol)) (defconstant +predefined-atoms+ '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP :CARDINAL :COLORMAP :CURSOR :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7 :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP :RGB_BLUE_MAP :RGB_DEFAULT_MAP :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING :VISUALID :WINDOW :WM_COMMAND :WM_HINTS :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y :SUBSCRIPT_X :SUBSCRIPT_Y :UNDERLINE_POSITION :UNDERLINE_THICKNESS :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT :WM_CLASS :WM_TRANSIENT_FOR)) (deftype stringable () '(or string symbol)) (deftype fontable () '(or stringable font)) ; Nil stands for CurrentTime. (deftype timestamp () '(or null card32)) (defconstant +bit-gravity-vector+ '#(:forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (deftype bit-gravity () '(member :forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (defconstant +win-gravity-vector+ '#(:unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (defparameter *protocol-families* '(;; X11/X.h, Family* (:internet . 0) (:decnet . 1) (:chaos . 2) ;; X11/Xauth.h "not part of X standard" (:Local . 256) (:Wild . 65535) (:Netname . 254) (:Krb5Principal . 253) (:LocalHost . 252))) (deftype win-gravity () '(member :unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) (deftype grab-status () '(member :success :already-grabbed :invalid-time :not-viewable)) ; An association list. (deftype alist (key-type-and-name datum-type-and-name) (declare (ignore key-type-and-name datum-type-and-name)) 'list) (deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list) (deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence) ; A sequence, containing zero or more repetitions of the given elements, ; with the elements expressed as (type name). (deftype repeat-seq (&rest elts) elts 'sequence) (deftype point-seq () '(repeat-seq (int16 x) (int16 y))) (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) (deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) (angle angle1) (angle angle2))) (deftype gcontext-state () 'simple-vector) (def-clx-class (gcontext (:copier nil) (:print-function print-gcontext)) ;; The accessors convert to CLX data types. (id 0 :type resource-id) (display nil :type (or null display)) (drawable nil :type (or null drawable)) (cache-p t :type generalized-boolean) (server-state (allocate-gcontext-state) :type gcontext-state) (local-state (allocate-gcontext-state) :type gcontext-state) (plist nil :type list) ; Extension hook (next nil #-explorer :type #-explorer (or null gcontext)) ) (defun print-gcontext (gcontext stream depth) (declare (type gcontext gcontext) (ignore depth)) (print-unreadable-object (gcontext stream :type t) (print-display-name (gcontext-display gcontext) stream) (write-string " " stream) (prin1 (gcontext-id gcontext) stream))) (defconstant +event-mask-vector+ '#(:key-press :key-release :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :keymap-state :exposure :visibility-change :structure-notify :resize-redirect :substructure-notify :substructure-redirect :focus-change :property-change :colormap-change :owner-grab-button)) (deftype event-mask-class () '(member :key-press :key-release :owner-grab-button :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :exposure :visibility-change :structure-notify :resize-redirect :substructure-notify :substructure-redirect :focus-change :property-change :colormap-change :keymap-state)) (deftype event-mask () '(or mask32 (clx-list event-mask-class))) (defconstant +pointer-event-mask-vector+ ;; the first two elements used to be '%error '%error (i.e. symbols, ;; and not keywords) but the vector is supposed to contain ;; keywords, so I renamed them -dan 2004.11.13 '#(:%error :%error :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :keymap-state)) (deftype pointer-event-mask-class () '(member :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :keymap-state)) (deftype pointer-event-mask () '(or mask32 (clx-list pointer-event-mask-class))) (defconstant +device-event-mask-vector+ '#(:key-press :key-release :button-press :button-release :pointer-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion)) (deftype device-event-mask-class () '(member :key-press :key-release :button-press :button-release :pointer-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion)) (deftype device-event-mask () '(or mask32 (clx-list device-event-mask-class))) (defconstant +state-mask-vector+ '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5 :button-1 :button-2 :button-3 :button-4 :button-5)) (deftype modifier-key () '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) (deftype modifier-mask () '(or (member :any) mask16 (clx-list modifier-key))) (deftype state-mask-key () '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) (defconstant +gcontext-components+ '(:function :plane-mask :foreground :background :line-width :line-style :cap-style :join-style :fill-style :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes :arc-mode)) (deftype gcontext-key () '(member :function :plane-mask :foreground :background :line-width :line-style :cap-style :join-style :fill-style :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes :arc-mode)) (deftype event-key () '(or (member :key-press :key-release :button-press :button-release :motion-notify :enter-notify :leave-notify :focus-in :focus-out :keymap-notify :exposure :graphics-exposure :no-exposure :visibility-notify :create-notify :destroy-notify :unmap-notify :map-notify :map-request :reparent-notify :configure-notify :gravity-notify :resize-request :configure-request :circulate-notify :circulate-request :property-notify :selection-clear :selection-request :selection-notify :colormap-notify :client-message :mapping-notify) (satisfies extension-event-key-p))) (deftype error-key () '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice :illegal-request :implementation :length :match :name :pixmap :value :window)) (deftype draw-direction () '(member :left-to-right :right-to-left)) (defconstant +boole-vector+ '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1 #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2 #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)) (deftype boole-constant () `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1 ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2 ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set)) (def-clx-class (screen (:copier nil) (:print-function print-screen)) (root nil :type (or null window)) (width 0 :type card16) (height 0 :type card16) (width-in-millimeters 0 :type card16) (height-in-millimeters 0 :type card16) (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals))) (root-depth 1 :type image-depth) (root-visual-info nil :type (or null visual-info)) (default-colormap nil :type (or null colormap)) (white-pixel 0 :type pixel) (black-pixel 1 :type pixel) (min-installed-maps 1 :type card16) (max-installed-maps 1 :type card16) (backing-stores :never :type (member :never :when-mapped :always)) (save-unders-p nil :type generalized-boolean) (event-mask-at-open 0 :type mask32) (plist nil :type list) ; Extension hook ) (defun print-screen (screen stream depth) (declare (type screen screen) (ignore depth)) (print-unreadable-object (screen stream :type t) (let ((display (drawable-display (screen-root screen)))) (print-display-name display stream) (write-string "." stream) (princ (position screen (display-roots display)) stream)) (write-string " " stream) (prin1 (screen-width screen) stream) (write-string "x" stream) (prin1 (screen-height screen) stream) (write-string "x" stream) (prin1 (screen-root-depth screen) stream) (when (screen-root-visual-info screen) (write-string " " stream) (princ (visual-info-class (screen-root-visual-info screen)) stream)))) (defun screen-root-visual (screen) (declare (type screen screen) (clx-values resource-id)) (visual-info-id (screen-root-visual-info screen))) ;; The list contains alternating keywords and integers. (deftype font-props () 'list) (def-clx-class (font-info (:copier nil) (:predicate nil)) (direction :left-to-right :type draw-direction) (min-char 0 :type card16) ;; First character in font (max-char 0 :type card16) ;; Last character in font (min-byte1 0 :type card8) ;; The following are for 16 bit fonts (max-byte1 0 :type card8) ;; and specify min&max values for (min-byte2 0 :type card8) ;; the two character bytes (max-byte2 0 :type card8) (all-chars-exist-p nil :type generalized-boolean) (default-char 0 :type card16) (min-bounds nil :type (or null vector)) (max-bounds nil :type (or null vector)) (ascent 0 :type int16) (descent 0 :type int16) (properties nil :type font-props)) (def-clx-class (font (:constructor make-font-internal) (:copier nil) (:print-function print-font)) (id-internal nil :type (or null resource-id)) ;; NIL when not opened (display nil :type (or null display)) (reference-count 0 :type fixnum) (name "" :type (or null string)) ;; NIL when ID is for a GContext (font-info-internal nil :type (or null font-info)) (char-infos-internal nil :type (or null (simple-array int16 (*)))) (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally (plist nil :type list) ; Extension hook ) (defun print-font (font stream depth) (declare (type font font) (ignore depth)) (print-unreadable-object (font stream :type t) (if (font-name font) (princ (font-name font) stream) (write-string "(gcontext)" stream)) (write-string " " stream) (print-display-name (font-display font) stream) (when (font-id-internal font) (write-string " " stream) (prin1 (font-id font) stream)))) (defun font-id (font) ;; Get font-id, opening font if needed (or (font-id-internal font) (open-font-internal font))) (defun font-font-info (font) (or (font-font-info-internal font) (query-font font))) (defun font-char-infos (font) (or (font-char-infos-internal font) (progn (query-font font) (font-char-infos-internal font)))) (defun make-font (&key id display (reference-count 0) (name "") (local-only-p t) font-info-internal) (make-font-internal :id-internal id :display display :reference-count reference-count :name name :local-only-p local-only-p :font-info-internal font-info-internal)) ; For each component ( :type ) of font-info, ; there is a corresponding function: ;(defun font- (font) ; (declare (type font font) ; (clx-values ))) (macrolet ((make-font-info-accessors (useless-name &body fields) `(within-definition (,useless-name make-font-info-accessors) ,@(mapcar #'(lambda (field) (let* ((type (second field)) (n (string (first field))) (name (xintern 'font- n)) (accessor (xintern 'font-info- n))) `(defun ,name (font) (declare (type font font)) (declare (clx-values ,type)) (,accessor (font-font-info font))))) fields)))) (make-font-info-accessors ignore (direction draw-direction) (min-char card16) (max-char card16) (min-byte1 card8) (max-byte1 card8) (min-byte2 card8) (max-byte2 card8) (all-chars-exist-p generalized-boolean) (default-char card16) (min-bounds vector) (max-bounds vector) (ascent int16) (descent int16) (properties font-props))) (defun font-property (font name) (declare (type font font) (type keyword name)) (declare (clx-values (or null int32))) (getf (font-properties font) name)) (macrolet ((make-mumble-equal (type) ;; Since caching is only done for objects created by the ;; client, we must always compare ID and display for ;; non-identical mumbles. (let ((predicate (xintern type '-equal)) (id (xintern type '-id)) (dpy (xintern type '-display))) `(within-definition (,type make-mumble-equal) (defun ,predicate (a b) (declare (type ,type a b)) (or (eql a b) (and (= (,id a) (,id b)) (eq (,dpy a) (,dpy b))))))))) (make-mumble-equal window) (make-mumble-equal pixmap) (make-mumble-equal cursor) (make-mumble-equal font) (make-mumble-equal gcontext) (make-mumble-equal colormap) (make-mumble-equal drawable)) ;;; ;;; Event-mask encode/decode functions ;;; Converts from keyword-lists to integer and back ;;; (defun encode-mask (key-vector key-list key-type) ;; KEY-VECTOR is a vector containg bit-position keywords. The ;; position of the keyword in the vector indicates its bit position ;; in the resulting mask. KEY-LIST is either a mask or a list of ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask. (declare (type (simple-array keyword (*)) key-vector) (type (or mask32 list) key-list)) (declare (clx-values (or mask32 null))) (typecase key-list (mask32 key-list) (list (let ((mask 0)) (dolist (key key-list mask) (let ((bit (position key (the vector key-vector) :test #'eq))) (unless bit (x-type-error key key-type)) (setq mask (logior mask (ash 1 bit))))))))) (defun decode-mask (key-vector mask) (declare (type (simple-array keyword (*)) key-vector) (type mask32 mask)) (declare (clx-values list)) (do ((m mask (ash m -1)) (bit 0 (1+ bit)) (len (length key-vector)) (result nil)) ((or (zerop m) (>= bit len)) result) (declare (type mask32 m) (fixnum bit len) (list result)) (when (oddp m) (push (aref key-vector bit) result)))) (defun encode-event-mask (event-mask) (declare (type event-mask event-mask)) (declare (clx-values mask32)) (or (encode-mask +event-mask-vector+ event-mask 'event-mask-class) (x-type-error event-mask 'event-mask))) (defun make-event-mask (&rest keys) ;; This is only defined for core events. ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. (declare (type (clx-list event-mask-class) keys)) (declare (clx-values mask32)) (encode-mask +event-mask-vector+ keys 'event-mask-class)) (defun make-event-keys (event-mask) ;; This is only defined for core events. (declare (type mask32 event-mask)) (declare (clx-values (clx-list event-mask-class))) (decode-mask +event-mask-vector+ event-mask)) (defun encode-device-event-mask (device-event-mask) (declare (type device-event-mask device-event-mask)) (declare (clx-values mask32)) (or (encode-mask +device-event-mask-vector+ device-event-mask 'device-event-mask-class) (x-type-error device-event-mask 'device-event-mask))) (defun encode-modifier-mask (modifier-mask) (declare (type modifier-mask modifier-mask)) (declare (clx-values mask16)) (or (and (eq modifier-mask :any) #x8000) (encode-mask +state-mask-vector+ modifier-mask 'modifier-key) (x-type-error modifier-mask 'modifier-mask))) (defun encode-state-mask (state-mask) (declare (type (or mask16 (clx-list state-mask-key)) state-mask)) (declare (clx-values mask16)) (or (encode-mask +state-mask-vector+ state-mask 'state-mask-key) (x-type-error state-mask '(or mask16 (clx-list state-mask-key))))) (defun make-state-mask (&rest keys) ;; Useful for constructing modifier-mask, state-mask. (declare (type (clx-list state-mask-key) keys)) (declare (clx-values mask16)) (encode-mask +state-mask-vector+ keys 'state-mask-key)) (defun make-state-keys (state-mask) (declare (type mask16 state-mask)) (declare (clx-values (clx-list state-mask-key))) (decode-mask +state-mask-vector+ state-mask)) (defun encode-pointer-event-mask (pointer-event-mask) (declare (type pointer-event-mask pointer-event-mask)) (declare (clx-values mask32)) (or (encode-mask +pointer-event-mask-vector+ pointer-event-mask 'pointer-event-mask-class) (x-type-error pointer-event-mask 'pointer-event-mask))) cmucl-21a/src/clx/cmudep.lisp000066400000000000000000000012321260377556400163020ustar00rootroot00000000000000;;; -*- Package: XLIB -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/clx/cmudep.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "XLIB") (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) c-call:int (host c-call:c-string) (port c-call:int)) cmucl-21a/src/clx/debug/000077500000000000000000000000001260377556400152245ustar00rootroot00000000000000cmucl-21a/src/clx/debug/debug.lisp000066400000000000000000000043021260377556400172020ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*- ;;; CLX debugging code ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Created 04/09/87 14:30:41 by LaMott G. OREN #+cmu (ext:file-comment "$Id: debug.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (export '(display-listen readflush check-buffer check-finish check-force clear-next)) (defun display-listen (display) (listen (display-input-stream display))) (defun readflush (display) ;; Flushes Display's input stream, returning what was there (let ((stream (display-input-stream display))) (loop while (listen stream) collect (read-byte stream)))) ;;----------------------------------------------------------------------------- ;; The following are useful display-after functions (defun check-buffer (display) ;; Ensure the output buffer in display is correct (with-buffer-output (display :length :none :sizes (8 16)) (do* ((i 0 (+ i length)) request length) ((>= i buffer-boffset) (unless (= i buffer-boffset) (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) (let ((buffer-boffset 0) #+clx-overlapping-arrays (buffer-woffset 0)) (setq request (card8-get i)) (setq length (* 4 (card16-get (+ i 2))))) (when (zerop request) (warn "Zero request in buffer") (return nil)) (when (zerop length) (warn "Zero length in buffer") (return nil))))) (defun check-finish (display) (check-buffer display) (display-finish-output display)) (defun check-force (display) (check-buffer display) (display-force-output display)) (defun clear-next (display) ;; Never append requests (setf (display-last-request display) nil)) ;; End of file cmucl-21a/src/clx/debug/describe.lisp000066400000000000000000000611341260377556400177020ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: XLIB; Syntax: COMMON-LISP; Base: 10; Lowercase: Yes; -*- ;;; Describe X11 protocol requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Created 07/15/87 by LaMott G. OREN #cmu (ext:file-comment "$Id: describe.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defparameter *request-parameters* (make-array (length *request-names*))) (defmacro x-request (name &rest fields) (unless (zerop (mod (length fields) 3)) (format t "~%Field length not a multiple of 3 for ~a" name)) (let ((request (position name *request-names* :test #'string-equal))) (if request `(setf (aref *request-parameters* ,request) ',fields) `(format t "~%~s isn't an X11 request name" ',name)))) (defun print-history-description (buffer &optional (start 0)) ;; Display an output history (reading-event (buffer) (let ((request (card8-get start)) (length (* 4 (card16-get (+ start 2)))) (margin 5)) (format t "~a (~d) length ~d" (request-name request) request length) (when (>= request (length *request-parameters*)) (setq request 0)) (do ((parms (aref *request-parameters* request) (cdddr parms)) (j start)) ((or (endp parms) (>= j length))) (let ((len (first parms)) (type (second parms)) (doc (third parms)) value) (setq value (case len (1 (card8-get j)) (2 (card16-get j)) (4 (card32-get j)))) (format t "~%~v@t" margin) (if value (progn (print-value j value type doc) (incf j len)) (progn (format t "~2d ~10a ~a" j type doc) (case type ((listofvalue listofcard32 listofatom) (format t " Words:~%~v@t" margin) (dotimes (k (floor (- length (- j start)) 4)) (format t " ~d" (card32-get j)) (incf j 4))) (listofrectangle (format t " Half-Words:~%~v@t" margin) (dotimes (k (floor (- length (- j start)) 2)) (format t " ~d" (card16-get j)) (incf j 2))) (x (when (integerp len) (incf j len))) ; Unused (string8 (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) (format t "~a" (int-char (card8-get j))) (incf j))) (otherwise (format t " Bytes:~%~v@t" margin) (dotimes (k (- length (- j start))) (format t " ~d" (card8-get j)) (incf j))))))))))) (defun print-value (i value type doc &aux temp) (format t "~2d ~3d " i value) (if (consp type) (case (first type) (bitmask (format t "~a" (nreverse (decode-mask (symbol-value (second type)) value))) (setq type (car type))) (member (if (null (setq temp (nth value (cdr type)))) (format t "*****ERROR*****") (format t "~a" temp)) (setq type (car type)))) (case type ((window pixmap drawable cursor font gcontext colormap atom) (format t "[#x~x]" value) #+comment (let ((temp (lookup-resource-id display value))) (when (eq (first type) 'atom) (setq temp (lookup-xatom display value))) (when temp (format t " (~s)" (type-of temp))))) (int16 (setq temp (card16->int16 value)) (when (minusp temp) (format t "~d" temp))) (otherwise (when (and (numberp type) (not (= type value))) (format t "*****ERROR*****"))))) (format t "~30,10t ~10a ~a" type doc)) (x-request Error 1 1 opcode 1 CARD8 data 2 8+n request-length n LISTofBYTE data ) (x-request CreateWindow 1 1 opcode 1 CARD8 depth 2 8+n request-length 4 WINDOW wid 4 WINDOW parent 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height 2 CARD16 border-width 2 (MEMBER CopyFromParent InputOutput InputOnly) class 4 (OR (MEMBER CopyFromParent) VISUALID) visual 4 (BITMASK *create-bitmask*) value-mask 4n LISTofVALUE value-list ) (defparameter *create-bitmask* #(background-pixmap background-pixel border-pixmap border-pixel bit-gravity win-gravity backing-store backing-planes backing-pixel override-redirect save-under event-mask do-not-propagate-mask colormap cursor)) (x-request ChangeWindowAttributes 1 2 opcode 1 x unused 2 3+n request-length 4 WINDOW window 4 (BITMASK *create-bitmask*) value-mask 4n LISTofVALUE value-list ) (x-request GetWindowAttributes 1 3 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request DestroyWindow 1 4 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request DestroySubwindows 1 5 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request ChangeSaveSet 1 6 opcode 1 (MEMBER insert delete) mode 2 2 request-length 4 WINDOW window ) (x-request ReparentWindow 1 7 opcode 1 x unused 2 4 request-length 4 WINDOW window 4 WINDOW parent 2 INT16 x 2 INT16 y ) (x-request MapWindow 1 8 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request MapSubwindows 1 9 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request UnmapWindow 1 10 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request UnmapSubwindows 1 11 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request ConfigureWindow 1 12 opcode 1 x unused 2 3+n request-length 4 WINDOW window 2 BITMASK value-mask 2 x unused 4n LISTofVALUE value-list ) (x-request CirculateWindow 1 13 opcode 1 (MEMBER RaiseLowest LowerHighest) direction 2 2 request-length 4 WINDOW window ) (x-request GetGeometry 1 14 opcode 1 x unused 2 2 request-length 4 DRAWABLE drawable ) (x-request QueryTree 1 15 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request InternAtom 1 16 opcode 1 BOOL only-if-exists 2 |2+(n+p)/4| request-length 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request GetAtomName 1 17 opcode 1 x unused 2 2 request-length 4 ATOM atom ) (x-request ChangeProperty 1 18 opcode 1 (MEMBER replace prepend append) mode 2 |6+(n+p)/4| request-length 4 WINDOW window 4 ATOM property 4 ATOM type 1 CARD8 format 3 x unused 4 CARD32 length-of-data-in-format-units n LISTofBYTE data p x unused ) (x-request DeleteProperty 1 19 opcode 1 x unused 2 3 request-length 4 WINDOW window 4 ATOM property ) (x-request GetProperty 1 20 opcode 1 BOOL delete 2 6 request-length 4 WINDOW window 4 ATOM property 4 (OR (MEMBER anypropertytype) ATOM) type 4 CARD32 long-offset 4 CARD32 long-length ) (x-request ListProperties 1 21 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request SetSelectionOwner 1 22 opcode 1 x unused 2 4 request-length 4 (OR (MEMBER none) WINDOW) owner 4 ATOM selection 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GetSelectionOwner 1 23 opcode 1 x unused 2 2 request-length 4 ATOM selection ) (x-request ConvertSelection 1 24 opcode 1 x unused 2 6 request-length 4 WINDOW requestor 4 ATOM selection 4 ATOM target 4 (OR (MEMBER none) ATOM) property 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request SendEvent 1 25 opcode 1 BOOL propagate 2 11 request-length 4 (OR (MEMBER pointerwindow inputfocus) WINDOW) destination 4 SETofEVENT event-mask 32 n event ) (x-request GrabPointer 1 26 opcode 1 BOOL owner-events 2 6 request-length 4 WINDOW grab-window 2 SETofPOINTEREVENT event-mask 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 4 (OR (MEMBER none) WINDOW) confine-to 4 (OR (MEMBER none) CURSOR) cursor 4 (OR (MEMBER currenttime) TIMESTAMP) timestamp ) (x-request UngrabPointer 1 27 opcode 1 x unused 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabButton 1 28 opcode 1 BOOL owner-events 2 6 request-length 4 WINDOW grab-window 2 SETofPOINTEREVENT event-mask 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 4 (OR (MEMBER none) WINDOW) confine-to 4 (OR (MEMBER none) CURSOR) cursor 1 (OR (MEMBER anybutton) BUTTON)button 1 x unused 2 SETofKEYMASK modifiers ) (x-request UngrabButton 1 29 opcode 1 (OR (MEMBER anybutton) BUTTON) button 2 3 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 2 x unused ) (x-request ChangeActivePointerGrab 1 30 opcode 1 x unused 2 4 request-length 4 (OR (MEMBER none) CURSOR) cursor 4 (OR (MEMBER currenttime) TIMESTAMP) time 2 SETofPOINTEREVENT event-mask 2 x unused ) (x-request GrabKeyboard 1 31 opcode 1 BOOL owner-events 2 4 request-length 4 WINDOW grab-window 4 (OR (MEMBER currenttime) TIMESTAMP) time 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 2 x unused ) (x-request UngrabKeyboard 1 32 opcode 1 x unused 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabKey 1 33 opcode 1 BOOL owner-events 2 4 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 1 (OR (MEMBER anykey) KEYCODE) key 1 (MEMBER Synchronous Asynchronous) pointer-mode 1 (MEMBER Synchronous Asynchronous) keyboard-mode 3 x unused ) (x-request UngrabKey 1 34 opcode 1 (OR (MEMBER anykey) KEYCODE) key 2 3 request-length 4 WINDOW grab-window 2 SETofKEYMASK modifiers 2 x unused ) (x-request AllowEvents 1 35 opcode 1 (MEMBER AsyncPointer SyncPointer ReplayPointer AsyncKeyboard SyncKeyboard ReplayKeyboard) mode 2 2 request-length 4 (OR (MEMBER currenttime) TIMESTAMP) time ) (x-request GrabServer 1 36 opcode 1 x unused 2 1 request-length ) (x-request UngrabServer 1 37 opcode 1 x unused 2 1 request-length ) (x-request QueryPointer 1 38 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request GetMotionEvents 1 39 opcode 1 x unused 2 4 request-length 4 WINDOW window 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) start 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) stop ) (x-request TranslateCoords 1 40 opcode 1 x unused 2 4 request-length 4 WINDOW src-window 4 WINDOW dst-window 2 INT16 src-x 2 INT16 src-y ) (x-request WarpPointer 1 41 opcode 1 x unused 2 6 request-length 4 (OR (MEMBER none) WINDOW) src-window 4 WINDOW dst-window 2 INT16 src-x 2 INT16 src-y 2 CARD16 src-width 2 CARD16 src-height 2 INT16 dst-x 2 INT16 dst-y ) (x-request SetInputFocus 1 42 opcode 1 (MEMBER none pointerroot parent) revert-to 2 3 request-length 4 (OR (MEMBER none pointerroot) WINDOW) focus 4 (OR (MEMBER CURRENTTIME) TIMESTAMP) time ) (x-request GetInputFocus 1 43 opcode 1 x unused 2 1 request-length ) (x-request QueryKeymap 1 44 opcode 1 x unused 2 1 request-length ) (x-request OpenFont 1 45 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 FONT fid 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request CloseFont 1 46 opcode 1 x unused 2 2 request-length 4 FONT font ) (x-request QueryFont 1 47 opcode 1 x unused 2 2 request-length 4 FONTABLE font ) (x-request QueryTextExtents 1 48 opcode 1 BOOL odd-length-p 2 |2+(2n+p)/4| request-length 4 FONTABLE font 2n STRING16 string p x unused ) (x-request ListFonts 1 49 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 max-names 2 n length-of-pattern n STRING8 pattern p x unused ) (x-request ListFontsWithInfo 1 50 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 max-names 2 n length-of-pattern n STRING8 pattern p x unused ) (x-request SetFontPath 1 51 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 CARD16 number-of-STRs-in-path 2 x unused n LISTofSTR path p x unused ) (x-request GetFontPath 1 52 opcode 1 x unused 2 1 request-list ) (x-request CreatePixmap 1 53 opcode 1 CARD8 depth 2 4 request-length 4 PIXMAP pid 4 DRAWABLE drawable 2 CARD16 width 2 CARD16 height ) (x-request FreePixmap 1 54 opcode 1 x unused 2 2 request-length 4 PIXMAP pixmap ) (x-request CreateGC 1 55 opcode 1 x unused 2 4+n request-length 4 GCONTEXT cid 4 DRAWABLE drawable 4 (BITMASK *gc-bitmask*) value-mask 4n LISTofVALUE value-list ) (defconstant *gc-bitmask* #(function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule tile stipple tile-stipple-x-origin tile-stipple-y-origin font subwindow-mode graphics-exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes arc-mode)) (x-request ChangeGC 1 56 opcode 1 x unused 2 3+n request-length 4 GCONTEXT gc 4 (BITMASK *gc-bitmask*) value-mask 4n LISTofVALUE value-list ) (x-request CopyGC 1 57 opcode 1 x unused 2 4 request-length 4 GCONTEXT src-gc 4 GCONTEXT dst-gc 4 (BITMASK *gc-bitmask*) value-mask ) (x-request SetDashes 1 58 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 GCONTEXT gc 2 CARD16 dash-offset 2 n length-of-dashes n LISTofCARD8 dashes p x unused ) (x-request SetClipRectangles 1 59 opcode 1 (MEMBER UnSorted YSorted YXSorted YXBanded) ordering 2 3+2n request-length 4 GCONTEXT gc 2 INT16 clip-x-origin 2 INT16 clip-y-origin 8n LISTofRECTANGLE rectangles ) (x-request FreeGC 1 60 opcode 1 x unused 2 2 request-length 4 GCONTEXT gc ) (x-request ClearToBackground 1 61 opcode 1 BOOL exposures 2 4 request-length 4 WINDOW window 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height ) (x-request CopyArea 1 62 opcode 1 x unused 2 7 request-length 4 DRAWABLE src-drawable 4 DRAWABLE dst-drawable 4 GCONTEXT gc 2 INT16 src-x 2 INT16 src-y 2 INT16 dst-x 2 INT16 dst-y 2 CARD16 width 2 CARD16 height ) (x-request CopyPlane 1 63 opcode 1 x unused 2 8 request-length 4 DRAWABLE src-drawable 4 DRAWABLE dst-drawable 4 GCONTEXT gc 2 INT16 src-x 2 INT16 src-y 2 INT16 dst-x 2 INT16 dst-y 2 CARD16 width 2 CARD16 height 4 CARD32 bit-plane ) (x-request PolyPoint 1 64 opcode 1 (MEMBER origin previous) coordinate-mode 2 3+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 4n LISTofPOINT points ) (x-request PolyLine 1 65 opcode 1 (MEMBER origin previous) coordinate-mode 2 3+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 4n LISTofPOINT points ) (x-request PolySegment 1 66 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofSEGMENT segments ) (x-request PolyRectangle 1 67 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofRECTANGLE rectangles ) (x-request PolyArc 1 68 opcode 1 x unused 2 3+3n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 12n LISTofARC arcs ) (x-request FillPoly 1 69 opcode 1 x unused 2 4+n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 1 (MEMBER complex nonconvex convex) shape 1 (MEMBER origin previous) coordinate-mode 2 x unused 4n LISTofPOINT points ) (x-request PolyFillRectangle 1 70 opcode 1 x unused 2 3+2n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 8n LISTofRECTANGLE rectangles ) (x-request PolyFillArc 1 71 opcode 1 x unused 2 3+3n request-length 4 DRAWABLE drawable 4 GCONTEXT gc 12n LISTofARC arcs ) (x-request PutImage 1 72 opcode 1 (bitmap xypixmap zpixmap) format 2 |6+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 CARD16 width 2 CARD16 height 2 INT16 dst-x 2 INT16 dst-y 1 CARD8 left-pad 1 CARD8 depth 2 x unused n LISTofBYTE data p x unused ) (x-request GetImage 1 73 opcode 1 (MEMBER error xypixmap zpixmap) format 2 5 request-length 4 DRAWABLE drawable 2 INT16 x 2 INT16 y 2 CARD16 width 2 CARD16 height 4 CARD32 plane-mask ) (x-request PolyText8 1 74 opcode 1 x unused 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n LISTofTEXTITEM8 items p x unused ) (x-request PolyText16 1 75 opcode 1 x unused 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n LISTofTEXTITEM16 items p x unused ) (x-request ImageText8 1 76 opcode 1 n length-of-string 2 |4+(n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y n STRING8 string p x unused ) (x-request ImageText16 1 77 opcode 1 n number-of-CHAR2Bs-in-string 2 |4+(2n+p)/4| request-length 4 DRAWABLE drawable 4 GCONTEXT gc 2 INT16 x 2 INT16 y 2n STRING16 string p x unused ) (x-request CreateColormap 1 78 opcode 1 (MEMBER none all) alloc 2 4 request-length 4 COLORMAP mid 4 WINDOW window 4 VISUALID visual ) (x-request FreeColormap 1 79 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request CopyColormapAndFree 1 80 opcode 1 x unused 2 3 request-length 4 COLORMAP mid 4 COLORMAP src-cmap ) (x-request InstallColormap 1 81 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request UninstallColormap 1 82 opcode 1 x unused 2 2 request-length 4 COLORMAP cmap ) (x-request ListInstalledColormaps 1 83 opcode 1 x unused 2 2 request-length 4 WINDOW window ) (x-request AllocColor 1 84 opcode 1 x unused 2 4 request-length 4 COLORMAP cmap 2 CARD16 red 2 CARD16 green 2 CARD16 blue 2 x unused ) (x-request AllocNamedColor 1 85 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 COLORMAP cmap 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request AllocColorCells 1 86 opcode 1 BOOL contiguous 2 3 request-length 4 COLORMAP cmap 2 CARD16 colors 2 CARD16 planes ) (x-request AllocColorPlanes 1 87 opcode 1 BOOL contiguous 2 4 request-length 4 COLORMAP cmap 2 CARD16 colors 2 CARD16 reds 2 CARD16 greens 2 CARD16 blues ) (x-request FreeColors 1 88 opcode 1 x unused 2 3+n request-length 4 COLORMAP cmap 4 CARD32 plane-mask 4n LISTofCARD32 pixels ) (x-request StoreColors 1 89 opcode 1 x unused 2 2+3n request-length 4 COLORMAP cmap 12n LISTofCOLORITEM items ) (x-request StoreNamedColor 1 90 opcode 1 color-mask do-red_do-green_do-blue 2 |4+(n+p)/4| request-length 4 COLORMAP cmap 4 CARD32 pixel 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request QueryColors 1 91 opcode 1 x unused 2 2+n request-length 4 COLORMAP cmap 4n LISTofCARD32 pixels ) (x-request LookupColor 1 92 opcode 1 x unused 2 |3+(n+p)/4| request-length 4 COLORMAP cmap 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request CreateCursor 1 93 opcode 1 x unused 2 8 request-length 4 CURSOR cid 4 PIXMAP source 4 (OR (MEMBER none) PIXMAP) mask 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue 2 CARD16 x 2 CARD16 y ) (x-request CreateGlyphCursor 1 94 CreateGlyphCursor 1 x unused 2 8 request-length 4 CURSOR cid 4 FONT source-font 4 (OR (MEMBER none) FONT) mask-font 2 CARD16 source-char 2 CARD16 mask-char 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue ) (x-request FreeCursor 1 95 opcode 1 x unused 2 2 request-length 4 CURSOR cursor ) (x-request RecolorCursor 1 96 opcode 1 x unused 2 5 request-length 4 CURSOR cursor 2 CARD16 fore-red 2 CARD16 fore-green 2 CARD16 fore-blue 2 CARD16 back-red 2 CARD16 back-green 2 CARD16 back-blue ) (x-request QueryBestSize 1 97 opcode 1 (MEMBER cursor tile stipple) class 2 3 request-length 4 DRAWABLE drawable 2 CARD16 width 2 CARD16 height ) (x-request QueryExtension 1 98 opcode 1 x unused 2 |2+(n+p)/4| request-length 2 n length-of-name 2 x unused n STRING8 name p x unused ) (x-request ListExtensions 1 99 opcode 1 x unused 2 1 request-length ) (x-request SetKeyboardMapping 1 100 opcode 1 n keycode-count 2 2+nm request-length 1 KEYCODE first-keycode 1 m keysyms-per-keycode 2 x unused 4nm LISTofKEYSYM keysyms ) (x-request GetKeyboardMapping 1 101 opcode 1 x unused 2 2 request-length 1 KEYCODE first-keycode 1 CARD8 count 2 x unused ) (x-request ChangeKeyboardControl 1 102 opcode 1 x unused 2 2+n request-length 4 BITMASK value-mask 4n LISTofVALUE value-list ) (x-request GetKeyboardControl 1 103 opcode 1 x unused 2 1 request-length ) (x-request Bell 1 104 opcode 1 INT8 percent 2 1 request-length ) (x-request ChangePointerControl 1 105 opcode 1 x unused 2 3 request-length 2 INT16 acceleration-numerator 2 INT16 acceleration-denominator 2 INT16 threshold 1 BOOL do-acceleration 1 BOOL do-threshold ) (x-request GetPointerControl 1 106 GetPointerControl 1 x unused 2 1 request-length ) (x-request SetScreenSaver 1 107 opcode 1 x unused 2 3 request-length 2 INT16 timeout 2 INT16 interval 1 (MEMBER no yes default) prefer-blanking 1 (MEMBER no yes default) allow-exposures 2 x unused ) (x-request GetScreenSaver 1 108 opcode 1 x unused 2 1 request-length ) (x-request ChangeHosts 1 109 opcode 1 (MEMBER insert delete) mode 2 |2+(n+p)/4| request-length 1 (MEMBER internet decnet chaos) family 1 x unused 2 CARD16 length-of-address n LISTofCARD8 address p x unused ) (x-request ListHosts 1 110 opcode 1 x unused 2 1 request-length ) (x-request ChangeAccessControl 1 111 opcode 1 (MEMBER disable enable) mode 2 1 request-length ) (x-request ChangeCloseDownMode 1 112 opcode 1 (MEMBER destroy retainpermanent retaintemporary) mode 2 1 request-length ) (x-request KillClient 1 113 opcode 1 x unused 2 2 request-length 4 (MEMBER alltemporary CARD32) resource ) (x-request RotateProperties 1 114 opcode 1 x unused 2 3+n request-length 4 WINDOW window 2 n number-of-properties 2 INT16 delta 4n LISTofATOM properties ) (x-request ForceScreenSaver 1 115 ForceScreenSaver 1 (MEMBER reset activate) mode 2 1 request-length ) (x-request SetPointerMapping 1 116 opcode 1 n length-of-map 2 |1+(n+p)/4| request-length n LISTofCARD8 map p x unused ) (x-request GetPointerMapping 1 117 opcode 1 x unused 2 1 request-length ) (x-request SetModifierMapping 1 118 opcode 1 KEYCODE Lock 2 5 request-length 1 KEYCODE Shift_A 1 KEYCODE Shift_B 1 KEYCODE Control_A 1 KEYCODE Control_B 1 KEYCODE Mod1_A 1 KEYCODE Mod1_B 1 KEYCODE Mod2_A 1 KEYCODE Mod2_B 1 KEYCODE Mod3_A 1 KEYCODE Mod3_B 1 KEYCODE Mod4_A 1 KEYCODE Mod4_B 1 KEYCODE Mod5_A 1 KEYCODE Mod5_B 2 x unused ) (x-request GetModifierMapping 1 119 opcode 1 x unused 2 1 request-length ) #+comment (x-request NoOperation 1 127 opcode 1 x unused 2 1 request-length ) ;; End of file cmucl-21a/src/clx/debug/event-test.lisp000066400000000000000000000162431260377556400202210ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- ;;; This code was intended for CLUE. --FMG #+cmu (ext:file-comment "$Id: event-test.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XTEST" (:use :xlib :common-lisp) ) (in-package "XTEST") (defstruct event key ; Event key display ; Display event was reported to ;; The following are from the CLX event code state time event-window root drawable window child parent root-x root-y x y width height border-width override-redirect-p same-screen-p configure-p hint-p kind mode keymap focus-p count major minor above-sibling place atom selection requestor target property colormap new-p installed-p format type data send-event-p ) (defun process-input (display &optional timeout) "Process one event" (declare (type display display) ; The display (from initialize-clue) (type (or null number) timeout) ; optional timeout in seconds (values (or null character))) ; Returns NIL only if timeout exceeded (let ((event (make-event))) (setf (event-display event) display) (macrolet ((set-event (&rest parameters) `(progn ,@(mapcar #'(lambda (parm) `(setf (,(intern (concatenate 'string (string 'event-) (string parm))) event) ,parm)) parameters))) (dispatch (contact) `(dispatch-event event event-key send-event-p ,contact))) (let ((result (xlib:event-case (display :timeout timeout :force-output-p t) ((:key-press :key-release :button-press :button-release) (code time root window child root-x root-y x y state same-screen-p event-key send-event-p) (set-event code time root window child root-x root-y x y state same-screen-p) (dispatch window)) (:motion-notify (hint-p time root window child root-x root-y x y state same-screen-p event-key send-event-p) (set-event hint-p time root window child root-x root-y x y state same-screen-p) (dispatch window)) ((:enter-notify :leave-notify) (kind time root window child root-x root-y x y state mode focus-p same-screen-p event-key send-event-p) (set-event kind time root window child root-x root-y x y state mode focus-p same-screen-p) (dispatch window)) ((:focus-in :focus-out) (kind window mode event-key send-event-p) (set-event kind window mode) (dispatch window)) (:keymap-notify (window keymap event-key send-event-p) (set-event window keymap) (dispatch window)) (:exposure (window x y width height count event-key send-event-p) (set-event window x y width height count) (dispatch window)) (:graphics-exposure (drawable x y width height count major minor event-key send-event-p) (set-event drawable x y width height count major minor) (dispatch drawable)) (:no-exposure (drawable major minor event-key send-event-p) (set-event drawable major minor) (dispatch drawable)) (:visibility-notify (window state event-key send-event-p) (set-event window state) (dispatch window)) (:create-notify (parent window x y width height border-width override-redirect-p event-key send-event-p) (set-event parent window x y width height border-width override-redirect-p) (dispatch parent)) (:destroy-notify (event-window window event-key send-event-p) (set-event event-window window) (dispatch event-window)) (:unmap-notify (event-window window configure-p event-key send-event-p) (set-event event-window window configure-p) (dispatch event-window)) (:map-notify (event-window window override-redirect-p event-key send-event-p) (set-event event-window window override-redirect-p) (dispatch event-window)) (:map-request (parent window event-key send-event-p) (set-event parent window) (dispatch parent)) (:reparent-notify (event-window window parent x y override-redirect-p event-key send-event-p) (set-event event-window window parent x y override-redirect-p) (dispatch event-window)) (:configure-notify (event-window window above-sibling x y width height border-width override-redirect-p event-key send-event-p) (set-event event-window window above-sibling x y width height border-width override-redirect-p) (dispatch event-window)) (:configure-request (parent window above-sibling x y width height border-width event-key send-event-p) (set-event parent window above-sibling x y width height border-width) (dispatch parent)) (:gravity-notify (event-window window x y event-key send-event-p) (set-event event-window window x y) (dispatch event-window)) (:resize-request (window width height event-key send-event-p) (set-event window width height) (dispatch window)) (:circulate-notify (event-window window parent place event-key send-event-p) (set-event event-window window parent place) (dispatch event-window)) (:circulate-request (parent window place event-key send-event-p) (set-event parent window place) (dispatch parent)) (:property-notify (window atom time state event-key send-event-p) (set-event window atom time state) (dispatch window)) (:selection-clear (time window selection event-key send-event-p) (set-event time window selection) (dispatch window)) (:selection-request (time window requestor selection target property event-key send-event-p) (set-event time window requestor selection target property) (dispatch window)) (:selection-notify (time window selection target property event-key send-event-p) (set-event time window selection target property) (dispatch window)) (:colormap-notify (window colormap new-p installed-p event-key send-event-p) (set-event window colormap new-p installed-p) (dispatch window)) (:client-message (format window type data event-key send-event-p) (set-event format window type data) (dispatch window)) (:mapping-notify (request start count) (mapping-notify display request start count)) ;; Special case ))) (and result t))))) (defun event-case-test (display) ;; Tests universality of display, event-key, event-code, send-event-p and event-window (event-case (display) ((key-press key-release button-press button-release motion-notify enter-notify leave-notify focus-in focus-out keymap-notify exposure graphics-exposure no-exposure visibility-notify create-notify destroy-notify unmap-notify map-notify map-request reparent-notify configure-notify gravity-notify resize-request configure-request circulate-notify circulate-request property-notify selection-clear selection-request selection-notify colormap-notify client-message) (display event-key event-code send-event-p event-window) (print (list display event-key event-code send-event-p event-window))) (mapping-notify ;; mapping-notify doesn't have event-window (display event-key event-code send-event-p) (print (list display event-key event-code send-event-p))) )) cmucl-21a/src/clx/debug/keytrans.lisp000066400000000000000000000233141260377556400177600ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX keysym-translation test programs ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: keytrans.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun list-missing-keysyms () ;; Lists explorer characters which have no keysyms (dotimes (i 256) (unless (character->keysyms (int-char i)) (format t "~%(define-keysym ~@c ~d)" (int-char i) i)))) (defun list-multiple-keysyms () ;; Lists characters with more than one keysym (dotimes (i 256) (when (cdr (character->keysyms (int-char i))) (format t "~%Character ~@c [~d] has keysyms" (int-char i) i) (dolist (keysym (character->keysyms (int-char i))) (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) (defun check-lowercase-keysyms () ;; Checks for keysyms with incorrect :lowercase parameters (maphash #'(lambda (key mapping) (let* ((value (car mapping)) (char (keysym-mapping-object value))) (if (and (characterp char) (both-case-p char) (= (char-int char) (char-int (char-upcase char)))) ;; uppercase alphabetic character (unless (eq (keysym-mapping-lowercase value) (char-int (char-downcase char))) (let ((lowercase (keysym-mapping-lowercase value)) (should-be (char-downcase char))) (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" (ldb (byte 8 8) key) (ldb (byte 8 0) key) char (and lowercase (ldb (byte 8 8) lowercase)) (and lowercase (ldb (byte 8 0) lowercase)) (int-char lowercase) (ldb (byte 8 8) (char-int should-be)) (ldb (byte 8 0) (char-int should-be)) should-be))) (when (keysym-mapping-lowercase value) (let ((lowercase (keysym-mapping-lowercase value))) (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" (ldb (byte 8 8) key) (ldb (byte 8 0) key) char (and lowercase (ldb (byte 8 8) (char-int lowercase))) (and lowercase (ldb (byte 8 0) (char-int lowercase))) lowercase )))))) *keysym->character-map*)) (defun print-all-keysyms () (let ((all nil)) (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*) (setq all (sort all #'< :key #'car)) (format t "~%~d keysyms:" (length all)) (dolist (keysym all) (format t "~%~3d ~3d~{ ~s~}" (ldb (byte 8 8) (car keysym)) (ldb (byte 8 0) (car keysym)) (cadr keysym)) (dolist (mapping (cddr keysym)) (format t "~%~7@t~{ ~s~}" mapping))))) (defun keysym-mappings (keysym &key display (mask-format #'identity)) ;; Return all the keysym mappings for keysym. ;; Returns a list of argument lists that are argument-lists to define-keysym. ;; The following will re-create the mappings for KEYSYM: ;; (dolist (mapping (keysym-mappings) keysym) ;; (apply #'define-keysym mapping)) (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) (gethash keysym *keysym->character-map*))) (result nil)) (dolist (mapping mappings) (let ((object (keysym-mapping-object mapping)) (translate (keysym-mapping-translate mapping)) (lowercase (keysym-mapping-lowercase mapping)) (modifiers (keysym-mapping-modifiers mapping)) (mask (keysym-mapping-mask mapping))) (push (append (list object keysym) (when translate (list :translate translate)) (when lowercase (list :lowercase lowercase)) (when modifiers (list :modifiers (funcall mask-format modifiers))) (when mask (list :mask (funcall mask-format mask)))) result))) (nreverse result))) #+comment (defun print-keysym-mappings (keysym &optional display) (format t "~%(keysym ~d ~3d) " (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)) (dolist (mapping (keysym-mappings keysym :display display)) (format t "~16t~{ ~s~}~%" mapping))) (defun print-keysym-mappings (keysym &optional display) (flet ((format-mask (mask) (cond ((numberp mask) `(make-state-mask ,@(make-state-keys mask))) ((atom mask) mask) (t `(list ,@(mapcar #'(lambda (item) (if (numberp item) `(keysym ,(keysym-mapping-object (car (gethash item *keysym->character-map*)))) item)) mask)))))) (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" (car mapping) (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym) (cdr mapping))))) (defun keysym-test (host) ;; Server key-press Loop-back test (let* ((display (open-display host)) (width 400) (height 400) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press) :x 20 :y 20 :width width :height height)) #+comment (gc (create-gcontext :drawable win :background black :foreground white))) (initialize-extensions display) (map-window win) ; Map the window ;; Handle events (unwind-protect (dotimes (state 64) (do ((code (display-min-keycode display) (1+ code))) ((> code (display-max-keycode display))) (send-event win :key-press '(:key-press) :code code :state state :window win :root (screen-root screen) :time 0 :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) (event-case (display :force-output-p t :discard-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window)) nil) (key-press (display code state) (princ (keycode->character display code state)) t)))) (close-display display)))) (defun keysym-echo (host &optional keymap-p) ;; Echo characters typed to a window (let* ((display (open-display host)) (width 400) (height 400) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press :keymap-state :enter-window) :x 20 :y 20 :width width :height height)) (gc (create-gcontext :drawable win :background black :foreground white))) (initialize-extensions display) (map-window win) ; Map the window ;; Handle events (unwind-protect (event-case (display :force-output-p t :discard-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window) (draw-glyphs window gc 10 10 "Press to exit")) nil) (key-press (display code state) (let ((char (keycode->character display code state))) (format t "~%Code: ~s State: ~s Char: ~s" code state char) ;; (PRINC char) (PRINC " ") (when keymap-p (let ((keymap (query-keymap display))) (unless (character-in-map-p display char keymap) (print "character-in-map-p failed") (print-keymap keymap)))) ;; (when (eql char #\0) (setq disp display) (break)) (eql char #\escape))) (keymap-notify (keymap) (print "Keymap-notify") ;; we never get here. Server bug? (when (keysym-in-map-p display 65 keymap) (print "Found A")) (when (character-in-map-p display #\b keymap) (print "Found B"))) (enter-notify (event-window) (format t "~%Enter ~s" event-window))) (close-display display)))) (defun print-keymap (keymap) (do ((j 32 (+ j 32))) ;; first 32 bits is for window ((>= j 256)) (format t "~% ~3d: " j) (do ((i j (1+ i))) ((>= i (+ j 32))) (when (zerop (logand i 7)) (princ " ")) (princ (aref keymap i))))) (defun define-keysym-test (&key display printp (modifiers (list (keysym :left-meta))) (mask :modifiers)) (let* ((keysym 067) (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) (original (copy-tree (keysym-mappings keysym :display display)))) (when printp (print-keysym-mappings 67) (terpri)) (apply #'define-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display)) (should-be (append original (list args)))) (unless (equal is should-be) (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) (apply #'undefine-keysym args) (when printp (print-keysym-mappings 67) (terpri)) (let ((is (keysym-mappings keysym :display display))) (unless (equal is original) (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) (define-keysym-test) (define-keysym-test :modifiers (make-state-mask :shift :lock)) (define-keysym-test :modifiers (list :shift (keysym :left-meta) :control)) (define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil) cmucl-21a/src/clx/debug/trace.lisp000066400000000000000000000377201260377556400172240ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;; Trace works by substituting trace functions for the display-write/input functions. ;; The trace functions maintain a database of requests sent to the server in the ;; trace-history display property. This is an alist of (id . byte-vector) where ;; id is the request number for writes, :reply for replies, :event for events and ;; :error for errors. The alist is kept in reverse order (most recent first) ;; In a multiprocessing system is it very helpful to know what process wrote or ;; read certain requests. Thus I have modified the format of the trace-history ;; list. It is now an alist of: ((id . more-info) . byte-vector). ;; (more-info is a list returned by the trace-more-info function). ;; Also added the ability to suspend and resume tracing without destroying the ;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion. ;; 7feb91 -- jdi ;;; Created 09/14/87 by LaMott G. OREN #+cmu (ext:file-comment "$Id: trace.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (eval-when (load eval) (export '(trace-display suspend-display-tracing resume-display-tracing untrace-display show-trace display-trace ; for backwards compatibility describe-request describe-event describe-reply describe-error describe-trace))) (defun trace-display (display) "Start a trace on DISPLAY. If display is already being traced, this discards previous history. See show-trace and describe-trace." (declare (type display display)) (unless (getf (display-plist display) 'write-function) (bind-io-hooks display)) (setf (display-trace-history display) nil) t) (defun suspend-display-tracing (display) "Tracing is suspended, but history is not cleared." (if (getf (display-plist display) 'suspend-display-tracing) (warn "Tracing is already suspend for ~s" display) (progn (unbind-io-hooks display) (setf (getf (display-plist display) 'suspend-display-tracing) t)))) (defun resume-display-tracing (display) "Used to resume tracing after suspending" (if (getf (display-plist display) 'suspend-display-tracing) (progn (bind-io-hooks display) (remf (display-plist display) 'suspend-display-tracing)) (warn "Tracing was not suspended for ~s" display))) (defun untrace-display (display) "Stop tracing DISPLAY." (declare (type display display)) (if (not (getf (display-plist display) 'suspend-display-tracing)) (unbind-io-hooks display) (remf (display-plist display) 'suspend-display-tracing)) (setf (display-trace-history display) nil)) ;; Assumes tracing is not already on. (defun bind-io-hooks (display) (let ((write-function (display-write-function display)) (input-function (display-input-function display))) ;; Save origional write/input functions so we can untrace (setf (getf (display-plist display) 'write-function) write-function) (setf (getf (display-plist display) 'input-function) input-function) ;; Set new write/input functions that will record what's sent to the server (setf (display-write-function display) #'(lambda (vector display start end) (trace-write-hook vector display start end) (funcall write-function vector display start end))) (setf (display-input-function display) #'(lambda (display vector start end timeout) (let ((result (funcall input-function display vector start end timeout))) (unless result (trace-read-hook display vector start end)) result))))) (defun unbind-io-hooks (display) (let ((write-function (getf (display-plist display) 'write-function)) (input-function (getf (display-plist display) 'input-function))) (when write-function (setf (display-write-function display) write-function)) (when input-function (setf (display-input-function display) input-function)) (remf (display-plist display) 'write-function) (remf (display-plist display) 'input-function))) (defun byte-ref16 (vector index) #+clx-little-endian (logior (the card16 (ash (the card8 (aref vector (index+ index 1))) 8)) (the card8 (aref vector index))) #-clx-little-endian (logior (the card16 (ash (the card8 (aref vector index)) 8)) (the card8 (aref vector (index+ index 1))))) (defun byte-ref32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (values card32)) (declare-buffun) #+clx-little-endian (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i 3))) 24)) (the card29 (ash (the card8 (aref a (index+ i 2))) 16)) (the card16 (ash (the card8 (aref a (index+ i 1))) 8)) (the card8 (aref a i)))) #-clx-little-endian (the card32 (logior (the card32 (ash (the card8 (aref a i)) 24)) (the card29 (ash (the card8 (aref a (index+ i 1))) 16)) (the card16 (ash (the card8 (aref a (index+ i 2))) 8)) (the card8 (aref a (index+ i 3)))))) (defun trace-write-hook (vector display start end) ;; Called only by buffer-flush. Start should always be 0 (unless (zerop start) (format *debug-io* "write-called with non-zero start: ~d" start)) (let* ((history (display-trace-history display)) (request-number (display-request-number display)) (last-history (car history))) ;; There may be several requests in the buffer, and the last one may be ;; incomplete. The first one may be the completion of a previous request. ;; We can detect incomplete requests by comparing the expected length of ;; the last request with the actual length. (when (and last-history (numberp (caar last-history))) (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2))) (append-length (min (- last-length (length (cdr last-history))) (- end start)))) (when (plusp append-length) ;; Last history incomplete - append to last (setf (cdr last-history) (concatenate '(vector card8) (cdr last-history) (subseq vector start (+ start append-length)))) (index-incf start append-length)))) ;; Copy new requests into the history (do* ((new-history nil) (i start (+ i length)) request length) ((>= i end) ;; add in sequence numbers (dolist (entry new-history) (setf (caar entry) request-number) (decf request-number)) (setf (display-trace-history display) (nconc new-history history))) (setq request (aref vector i)) (setq length (index* 4 (byte-ref16 vector (+ i 2)))) (when (zerop length) (warn "Zero length in buffer") (return nil)) (push (cons (cons 0 (trace-more-info display request vector i (min (+ i length) end))) (subseq vector i (min (+ i length) end))) new-history) (when (zerop request) (warn "Zero length in buffer") (return nil))))) (defun trace-read-hook (display vector start end) ;; Reading is done with an initial length of 32 (with start = 0) ;; This may be followed by several other reads for long replies. (let* ((history (display-trace-history display)) (last-history (car history)) (length (- end start))) (when (and history (eq (caar last-history) :reply)) (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4)))) (append-length (min (- last-length (length (cdr last-history))) (- end start)))) (when (plusp append-length) (setf (cdr last-history) (concatenate '(vector card8) (cdr last-history) (subseq vector start (+ start append-length)))) (index-incf start append-length) (index-decf length append-length)))) ;; Copy new requests into the history (when (plusp length) (let ((reply-type (case (aref vector start) (0 :error) (1 :reply) (otherwise :event)))) (push (cons (cons reply-type (trace-more-info display reply-type vector start (+ start length))) (subseq vector start (+ start length))) (display-trace-history display)))))) (defun trace-more-info (display request-id vector start end) ;; Currently only returns current process. #+allegro (list mp::*current-process*)) (defun show-trace (display &key length show-process) "Display the trace history for DISPLAY. The default is to show ALL history entries. When the LENGTH parameter is used, only the last LENGTH entries are displayed." (declare (type display display)) (dolist (hist (reverse (subseq (display-trace-history display) 0 length))) (let* ((id (caar hist)) (more-info (cdar hist)) (vector (cdr hist)) (length (length vector)) (request (aref vector 0))) (format t "~%~5d " id) (case id (:error (trace-error-print display more-info vector)) (:event (format t "~a (~d) Sequence ~d" (if (< request (length *event-key-vector*)) (aref *event-key-vector* request) "Unknown") request (byte-ref16 vector 2)) (when show-process #+allegro (format t ", Proc ~a" (mp::process-name (car more-info))))) (:reply (format t "To ~d length ~d" (byte-ref16 vector 2) length) (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) (unless (= length actual-length) (format t " Should be ~d **************" actual-length))) (when show-process #+allegro (format t ", Proc ~a" (mp::process-name (car more-info))))) (otherwise (format t "~a (~d) length ~d" (request-name request) request length) (when show-process #+allegro (format t ", Proc ~a" (mp::process-name (car more-info))))))))) ;; For backwards compatibility (defun display-trace (&rest args) (apply 'show-trace args)) (defun find-trace (display type sequence &optional (number 0)) (dolist (history (display-trace-history display)) (when (and (symbolp (caar history)) (= (logandc2 (aref (cdr history) 0) 128) type) (= (byte-ref16 (cdr history) 2) sequence) (minusp (decf number))) (return (cdr history))))) (defun describe-error (display sequence) "Describe the error associated with request SEQUENCE." (let ((vector (find-trace display 0 sequence))) (if vector (progn (terpri) (trace-error-print display nil vector)) (format t "Error with sequence ~d not found." sequence)))) (defun trace-error-print (display more-info vector &optional (stream *standard-output*)) (let ((event (allocate-event))) ;; Copy into event from reply buffer (buffer-replace (reply-ibuf8 event) vector 0 *replysize*) (reading-event (event) (let* ((type (read-card8 0)) (error-code (read-card8 1)) (sequence (read-card16 2)) (resource-id (read-card32 4)) (minor-code (read-card16 8)) (major-code (read-card8 10)) (current-sequence (ldb (byte 16 0) (buffer-request-number display))) (error-key (if (< error-code (length *xerror-vector*)) (aref *xerror-vector* error-code) 'unknown-error)) (params (case error-key ((colormap-error cursor-error drawable-error font-error gcontext-error id-choice-error pixmap-error window-error) (list :resource-id resource-id)) (atom-error (list :atom-id resource-id)) (value-error (list :value resource-id)) (unknown-error ;; Prevent errors when handler is a sequence (setq error-code 0) (list :error-code error-code))))) type (let ((condition (apply #+lispm #'si:make-condition #+allegro #'make-condition #-(or lispm allegro) #'make-condition error-key :error-key error-key :display display :major major-code :minor minor-code :sequence sequence :current-sequence current-sequence params))) (princ condition stream) (deallocate-event event) condition))))) (defun describe-request (display sequence) "Describe the request with sequence number SEQUENCE" #+ti (si:load-if "clx:debug;describe") (let ((request (assoc sequence (display-trace-history display) :test #'(lambda (item key) (eql item (car key)))))) (if (null request) (format t "~%Request number ~d not found in trace history" sequence) (let* ((vector (cdr request)) (len (length vector)) (hist (make-reply-buffer len))) (buffer-replace (reply-ibuf8 hist) vector 0 len) (print-history-description hist))))) (defun describe-reply (display sequence) "Print the reply to request SEQUENCE. (The current implementation doesn't print very pretty)" (let ((vector (find-trace display 1 sequence)) (*print-array* t)) (if vector (print vector) (format t "~%Reply not found")))) (defun event-number (name) (if (integerp name) (let ((name (logandc2 name 128))) (if (typep name '(integer 0 63)) (aref *event-key-vector* name)) name) (position (string name) *event-key-vector* :test #'equalp :key #'string))) (defun describe-event (display name sequence &optional (number 0)) "Describe the event with event-name NAME and sequence number SEQUENCE. If there is more than one event, return NUMBER in the sequence." (declare (type display display) (type (or stringable (integer 0 63)) name) (integer sequence)) (let* ((event (event-number name)) (vector (and event (find-trace display event sequence number)))) (if (not event) (format t "~%~s isn't an event name" name) (if (not vector) (if (and (plusp number) (setq vector (find-trace display event sequence 0))) (do ((i 1 (1+ i)) (last-vector)) (nil) (if (setq vector (find-trace display event sequence i)) (setq last-vector vector) (progn (format t "~%Event number ~d not found, last event was ~d" number (1- i)) (return (trace-event-print display last-vector))))) (format t "~%Event ~s not found" (aref *event-key-vector* event))) (trace-event-print display vector))))) (defun trace-event-print (display vector) (let* ((event (allocate-event)) (event-code (ldb (byte 7 0) (aref vector 0))) (event-decoder (aref *event-handler-vector* event-code))) ;; Copy into event from reply buffer (setf (event-code event) event-code) (buffer-replace (reply-ibuf8 event) vector 0 *replysize*) (prog1 (funcall event-decoder display event #'(lambda (&rest args &key send-event-p &allow-other-keys) (setq args (copy-list args)) (remf args :display) (remf args :event-code) (unless send-event-p (remf args :send-event-p)) args)) (deallocate-event event)))) (defun describe-trace (display &optional length) "Display the trace history for DISPLAY. The default is to show ALL history entries. When the LENGTH parameter is used, only the last LENGTH entries are displayed." (declare (type display display)) #+ti (si:load-if "clx:debug;describe") (dolist (hist (reverse (subseq (display-trace-history display) 0 length))) (let* ((id (car hist)) (vector (cdr hist)) (length (length vector))) (format t "~%~5d " id) (case id (:error (trace-error-print display nil vector)) (:event (let ((event (trace-event-print display vector))) (when event (format t "from ~d ~{ ~s~}" (byte-ref16 vector 2) event)))) (:reply (format t "To ~d length ~d" (byte-ref16 vector 2) length) (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) (unless (= length actual-length) (format t " Should be ~d **************" actual-length))) (let ((*print-array* t) (*print-base* 16.)) (princ " ") (princ vector))) (otherwise (let* ((len (length vector)) (hist (make-reply-buffer len))) (buffer-replace (reply-ibuf8 hist) vector 0 len) (print-history-description hist))))))) ;; End of file cmucl-21a/src/clx/debug/util.lisp000066400000000000000000000121701260377556400170730ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*- ;; CLX utilities ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Created 04/09/87 14:30:41 by LaMott G. OREN #+cmu (ext:file-comment "$Id: util.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (export '(display-root display-black display-white report-events describe-window describe-gc degree radian display-refresh root-tree window-tree)) (defun display-root (display) (screen-root (display-default-screen display))) (defun display-black (display) (screen-black-pixel (display-default-screen display))) (defun display-white (display) (screen-white-pixel (display-default-screen display))) (defun report-events (display) (loop (unless (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001) (return nil)))) (defun describe-window (window) (macrolet ((da (attribute &key (transform 'progn) (format "~s")) (let ((func (intern (concatenate 'string (string 'window-) (string attribute)) 'xlib))) `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) (dg (attribute &key (transform 'progn) (format "~s")) (let ((func (intern (concatenate 'string (string 'drawable-) (string attribute)) 'xlib))) `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) (with-state (window) (when (window-p window) (da visual :format "#x~x") (da class) (da gravity) (da bit-gravity) (da backing-store) (da backing-planes :format "#x~x") (da backing-pixel) (da save-under) (da colormap) (da colormap-installed-p) (da map-state) (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") (da override-redirect) ) (dg root) (dg depth) (dg x) (dg y) (dg width) (dg height) (dg border-width) ))) (defun describe-gc (gc) (macrolet ((dgc (name &key (transform 'progn) (format "~s")) (let ((func (intern (concatenate 'string (string 'gcontext-) (string name)) 'xlib))) `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) (dgc function) (dgc plane-mask) (dgc foreground) (dgc background) (dgc line-width) (dgc line-style) (dgc cap-style) (dgc join-style) (dgc fill-style) (dgc fill-rule) (dgc tile) (dgc stipple) (dgc ts-x) (dgc ts-y) (dgc font) ;; See below (dgc subwindow-mode) (dgc exposures) (dgc clip-x) (dgc clip-y) ;; (dgc clip-ordering) (dgc clip-mask) (dgc dash-offset) (dgc dashes) (dgc arc-mode) )) (defun degree (degrees) (* degrees (/ pi 180))) (defun radian (radians) (round (* radians (/ 180 pi)))) (defun display-refresh (host) ;; Useful for when the system writes to the screen (sometimes scrolling!) (let ((display (open-display host))) (unwind-protect (let ((screen (display-default-screen display))) (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on :width (screen-width screen) :height (screen-height screen) :background (screen-black-pixel screen)))) (map-window win) (display-finish-output display) (unmap-window win) (destroy-window win) (display-finish-output display))) (close-display display)))) (defun root-tree (host) (let ((display (open-display host))) (unwind-protect (window-tree (screen-root (display-default-screen display))) (close-display display))) (values)) (defun window-tree (window &optional (depth 0)) ;; Print the window tree and properties starting from WINDOW ;; Returns a list of windows in the order that they are printed. (declare (arglist window) (type window window) (values (list window))) (let ((props (mapcar #'(lambda (prop) (multiple-value-bind (data type format) (get-property window prop) (case type (:string (setq data (coerce data 'string)))) (list prop format type data))) (list-properties window))) (result (list window))) (with-state (window) (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window) (drawable-x window) (drawable-y window) (drawable-width window) (drawable-height window) (window-map-state window))) (dolist (prop props) (format t "~%~v@t~{~s ~}" (+ depth 2) prop)) (dolist (w (query-tree window)) (setq result (nconc result (window-tree w (+ depth 2))))) result)) cmucl-21a/src/clx/defsystem.lisp000066400000000000000000000457071260377556400170470ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Portions Copyright (C) 1987 Texas Instruments Incorporated. ;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Franz Incorporated provides this software "as is" without express or ;;; implied warranty. ;;; #+ features used in this file ;;; clx-ansi-common-lisp ;;; lispm ;;; genera ;;; minima ;;; lucid ;;; lcl3.0 ;;; apollo ;;; kcl ;;; ibcl ;;; excl ;;; CMU ;;; sbcl #+cmu (ext:file-comment "$Id: defsystem.lisp,v 1.9 2009/06/17 18:22:45 rtoy Rel $") #+(or Genera Minima sbcl ecl) (eval-when (:compile-toplevel :load-toplevel :execute) (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*)) #+(and Genera clx-ansi-common-lisp) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) #-(or clx-ansi-common-lisp cmu) (lisp:in-package :user) #+cmu (lisp:in-package "XLIB") #+cmu (export 'load-clx) #+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) ;;;; Lisp Machines #+(and lispm (not genera)) (global:defsystem CLX (:pathname-default "clx:clx;") (:patchable "clx:patch;" clx-ti) (:initial-status :experimental) (:module package "package") (:module depdefs "depdefs") (:module clx "clx") (:module dependent "dependent") (:module macros "macros") (:module bufmac "bufmac") (:module buffer "buffer") (:module display "display") (:module gcontext "gcontext") (:module requests "requests") (:module input "input") (:module fonts "fonts") (:module graphics "graphics") (:module text "text") (:module attributes "attributes") (:module translate "translate") (:module keysyms "keysyms") (:module manager "manager") (:module image "image") (:module resource "resource") (:module doc "doc") (:compile-load package) (:compile-load depdefs (:fasload package)) (:compile-load clx (:fasload package depdefs)) (:compile-load dependent (:fasload package depdefs clx)) ;; Macros only needed for compilation (:skip :compile-load macros (:fasload package depdefs clx dependent)) ;; Bufmac only needed for compilation (:skip :compile-load bufmac (:fasload package depdefs clx dependent macros)) (:compile-load buffer (:fasload package depdefs clx dependent macros bufmac)) (:compile-load display (:fasload package depdefs clx dependent macros bufmac buffer)) (:compile-load gcontext (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load input (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load requests (:fasload package depdefs clx dependent macros bufmac buffer display input)) (:compile-load fonts (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load graphics (:fasload package depdefs clx dependent macros fonts bufmac buffer display fonts)) (:compile-load text (:fasload package depdefs clx dependent macros fonts bufmac buffer display gcontext fonts)) (:compile-load-init attributes (dependent) (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load translate (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load keysyms (:fasload package depdefs clx dependent macros bufmac buffer display translate)) (:compile-load manager (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load image (:fasload package depdefs clx dependent macros bufmac buffer display)) (:compile-load resource (:fasload package depdefs clx dependent macros bufmac buffer display)) (:auxiliary doc) ) ;;; Symbolics Lisp Machines #+Genera (scl:defsystem CLX (:default-pathname "SYS:X11;CLX;" :pretty-name "CLX" :maintaining-sites (:scrc) :distribute-sources t :distribute-binaries t :source-category :basic) (:module doc ("doc") (:type :lisp-example)) (:serial "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) #+Minima (zl:::scl:defsystem Minima-CLX (:default-pathname "SYS:X11;CLX;" :pretty-name "Minima CLX" :maintain-journals nil :maintaining-sites (:scrc) :distribute-sources t :distribute-binaries t :source-category :basic :default-module-type :minima-lisp) (:module doc ("doc") (:type :lisp-example)) (:serial "package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) ;;; Franz ;; ;; The following is a suggestion. If you comment out this form be ;; prepared for possible deadlock, since no interrupts will be recognized ;; while reading from the X socket if the scheduler is not running. ;; #+excl (setq compiler::generate-interrupt-checks-switch (compile nil '(lambda (safety size speed &optional debug) (declare (ignore size debug)) (or (< speed 3) (> safety 0))))) ;;; Allegro #+allegro (excl:defsystem :clx () |package| (|excldep| :load-before-compile (|package|) :recompile-on (|package|)) (|depdefs| :load-before-compile (|package| |excldep|) :recompile-on (|excldep|)) (|clx| :load-before-compile (|package| |excldep| |depdefs|) :recompile-on (|package| |excldep| |depdefs|)) (|dependent| :load-before-compile (|package| |excldep| |depdefs| |clx|) :recompile-on (|clx|)) (|exclcmac| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|) :recompile-on (|dependent|)) (|macros| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac|) :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros|) :recompile-on (|macros|)) (|buffer| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac|) :recompile-on (|bufmac|)) (|display| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer|) :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|input| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|requests| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |input|) :recompile-on (|display|)) (|fonts| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|graphics| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |fonts|) :recompile-on (|fonts|)) (|text| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |gcontext| |fonts|) :recompile-on (|gcontext| |fonts|) :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|translate| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |text|) :recompile-on (|display|)) (|keysyms| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |translate|) :recompile-on (|translate|)) (|manager| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|image| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ) #+allegro (excl:defsystem :clx-debug (:default-pathname "debug/" :needed-systems (:clx) :load-before-compile (:clx)) |describe| |keytrans| |trace| |util|) ;;;; Compile CLX ;;; COMPILE-CLX compiles the lisp source files and loads the binaries. ;;; It goes to some trouble to let the source files be in one directory ;;; and the binary files in another. Thus the same set of sources can ;;; be used for different machines and/or lisp systems. It also allows ;;; you to supply explicit extensions, so source files do not have to ;;; be renamed to fit into the naming conventions of an implementation. ;;; For example, ;;; (compile-clx "*.lisp" "machine/") ;;; compiles source files from the connected directory and puts them ;;; into the "machine" subdirectory. You can then load CLX out of the ;;; machine directory. ;;; The code has no knowledge of the source file types (eg, ".l" or ;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin"). Calling ;;; compile-file and load with a file type of NIL usually sorts things ;;; out correctly, but you may have to explicitly give the source and ;;; binary file types. ;;; An attempt at compiling the C language sources is also made, ;;; but you may have to set different compiler switches ;;; should be. If it doesn't do the right thing, then do ;;; (compile-clx "" "" :compile-c NIL) ;;; to prevent the compilation. ;;; compilation notes ;;; lucid2.0/hp9000s300 ;;; must uudecode the file make-sequence-patch.uu #+(or lucid kcl ibcl cmu) (defun clx-foreign-files (binary-path) #+(and lucid (not lcl3.0) (or mc68000 mc68020)) (load (merge-pathnames "make-sequence-patch" binary-path)) #+(and lucid apollo) (lucid::load-foreign-file (namestring (merge-pathnames "socket" binary-path)) :preserve-pathname t) #+(and lucid (not apollo)) (lucid::load-foreign-files (list (namestring (merge-pathnames "socket.o" binary-path))) '("-lc")) #+cmu (declare (ignore binary-path)) #+(or cmu sbcl) (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server) c-call:int (host c-call:c-string) (port c-call:int)) #+(or kcl ibcl) (progn (let ((pathname (merge-pathnames "sockcl.o" binary-path)) (options (concatenate 'string (namestring (merge-pathnames "socket.o" binary-path)) " -lc"))) (format t "~&Faslinking ~A with ~A.~%" pathname options) (si:faslink (namestring pathname) options) (format t "~&Finished faslinking ~A.~%" pathname))) ) #-(or lispm allegro Minima) (defun compile-clx (&optional (source-pathname-defaults "") (binary-pathname-defaults "") &key (compile-c t)) ;; The pathname-defaults above might only be strings, so coerce them ;; to pathnames. Build a default binary path with every component ;; of the source except the file type. This should prevent ;; (compile-clx "*.lisp") from destroying source files. (let* ((source-path (pathname source-pathname-defaults)) (path (make-pathname :host (pathname-host source-path) :device (pathname-device source-path) :directory (pathname-directory source-path) :name (pathname-name source-path) :type nil :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) #+clx-ansi-common-lisp (*compile-verbose* t) (*load-verbose* t)) ;; Make sure source-path and binary-path file types are distinct so ;; we don't accidently overwrite the source files. NIL should be an ;; ok type, but anything else spells trouble. (if (and (equal (pathname-type source-path) (pathname-type binary-path)) (not (null (pathname-type binary-path)))) (error "Source and binary pathname defaults have same type ~s ~s" source-path binary-path)) (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path) ;; In lucid make sure we're using the compiler in production mode. #+lcl3.0 (progn (unless (member :pqc *features*) (cerror "Go ahead anyway." "Lucid's production mode compiler must be loaded to compile CLX.")) (proclaim '(optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))) (labels ((compile-lisp (filename) (let ((source (merge-pathnames filename source-path)) (binary (merge-pathnames filename binary-path))) ;; If the source and binary pathnames are the same, ;; then don't supply an output file just to be sure ;; compile-file defaults correctly. #+(or kcl ibcl) (load source) (if (equal source binary) (compile-file source) (compile-file source :output-file binary)) binary)) (compile-and-load (filename) (load (compile-lisp filename))) #+(or lucid kcl ibcl) (compile-c (filename) (let* ((c-filename (concatenate 'string filename ".c")) (o-filename (concatenate 'string filename ".o")) (src (merge-pathnames c-filename source-path)) (obj (merge-pathnames o-filename binary-path)) (args (list "-c" (namestring src) "-o" (namestring obj) #+mips "-G 0" #+(or hp sysv) "-DSYSV" #+(and mips (not dec)) "-I/usr/include/bsd" #-(and mips (not dec)) "-DUNIXCONN" #+(and lucid pa) "-DHPUX -DHPUX7.0" ))) (format t ";;; cc~{ ~A~}~%" args) (unless (zerop #+lucid (multiple-value-bind (iostream estream exitstatus pid) ;; in 2.0, run-program is exported from system: ;; in 3.0, run-program is exported from lcl: ;; system inheirits lcl (system::run-program "cc" :arguments args) (declare (ignore iostream estream pid)) exitstatus) #+(or kcl ibcl) (system (format nil "cc~{ ~A~}" args))) (error "Compile of ~A failed." src))))) ;; Now compile and load all the files. ;; Defer compiler warnings until everything's compiled, if possible. (#+(or clx-ansi-common-lisp CMU) with-compilation-unit #+lcl3.0 lucid::with-deferred-warnings #-(or lcl3.0 clx-ansi-common-lisp CMU) progn () (compile-and-load "package") #+(or lucid kcl ibcl) (when compile-c (compile-c "socket")) #+(or kcl ibcl) (compile-lisp "sockcl") #+(or lucid kcl ibcl) (clx-foreign-files binary-path) #+excl (compile-and-load "excldep") (compile-and-load "depdefs") (compile-and-load "clx") (compile-and-load "dependent") #+excl (compile-and-load "exclcmac") ; these are just macros (compile-and-load "macros") ; these are just macros (compile-and-load "bufmac") ; these are just macros (compile-and-load "buffer") (compile-and-load "display") (compile-and-load "gcontext") (compile-and-load "input") (compile-and-load "requests") (compile-and-load "fonts") (compile-and-load "graphics") (compile-and-load "text") (compile-and-load "attributes") (compile-and-load "translate") (compile-and-load "keysyms") (compile-and-load "manager") (compile-and-load "image") (compile-and-load "resource") )))) ;;;; Load CLX ;;; This procedure loads the binaries for CLX. All of the binaries ;;; should be in the same directory, so setting the default pathname ;;; should point load to the right place. ;;; You should have a module definition somewhere so the require/provide ;;; mechanism can avoid reloading CLX. In an ideal world, somebody would ;;; just put ;;; (REQUIRE 'CLX) ;;; in their file (some implementations don't have a central registry for ;;; modules, so a pathname needs to be supplied). ;;; The REQUIRE should find a file that does ;;; (IN-PACKAGE 'XLIB :USE '(LISP)) ;;; (PROVIDE 'CLX) ;;; (LOAD ) ;;; (LOAD-CLX ) #-(or lispm allegro Minima) (defun load-clx (&optional (binary-pathname-defaults "") &key (macrosp nil)) (let* ((source-path (pathname "")) (path (make-pathname :host (pathname-host source-path) :device (pathname-device source-path) :directory (pathname-directory source-path) :name (pathname-name source-path) :type nil :version (pathname-version source-path))) (binary-path (merge-pathnames binary-pathname-defaults path)) (*load-verbose* t)) (flet ((load-binary (filename) (let ((binary (merge-pathnames filename binary-path))) (load binary)))) (load-binary "package") #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path) #+excl (load-binary "excldep") (load-binary "depdefs") (load-binary "clx") (load-binary "dependent") (when macrosp #+excl (load-binary "exclcmac") (load-binary "macros") (load-binary "bufmac")) (load-binary "buffer") (load-binary "display") (load-binary "gcontext") (load-binary "input") (load-binary "requests") (load-binary "fonts") (load-binary "graphics") (load-binary "text") (load-binary "attributes") (load-binary "translate") (load-binary "keysyms") (load-binary "manager") (load-binary "image") (load-binary "resource") ))) ;;; ;;; ECL likes to combine several files into a single dynamically loadable ;;; library. ;;; #+ecl (defconstant +clx-modules+ '("package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" "text" "attributes" "translate" "keysyms" "manager" "image" "resource")) #+(or) ;ecl (flet ((compile-if-old (destdir sources &rest options) (mapcar #'(lambda (source) (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object)))) (unless (and (probe-file object) (>= (file-write-date object) (file-write-date source))) (apply #'compile-file source :output-file object options)) object)) sources))) (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t))) (c::build-fasl "clx" :lisp-files clx-objects))) (mapcar #'load +clx-modules+) cmucl-21a/src/clx/demo/000077500000000000000000000000001260377556400150625ustar00rootroot00000000000000cmucl-21a/src/clx/demo/README000066400000000000000000000024611260377556400157450ustar00rootroot00000000000000$Id: README,v 1.1 2007/08/21 15:49:29 fgilham Rel $ A brief description of the files in this directory, as best I (FMG) can figure. bezier.lisp: An example of how to define an extension. As far as I know, there's no bezier extension in most X servers, so this won't do much. beziertest.lisp: An example of how to invoke the bezier extension. Both the above files are obsolete. clclock.lisp: Display a clock using Roman numerals. Works. clipboard.lisp: Shows how to manage cut-and-paste (the X clipboard). Works. clx-demos.lisp: Some old graphics demos. Works. Many of them have been updated in the cmucl src/contrib/demos directory. gl-test.lisp: A test and demonstration of the GL interface. Seems to mostly work on my system. hello.lisp: A hello-world X program that gives a kind of skeleton for X programs. Works. mandel.lisp: A Mandelbrot set generator that I couldn't get to work, even by hacking quite a bit on it. There are some obvious problems in the code that I tried fixing and some less obvious ones that I couldn't fix. The code here is as I originally found it. menu.lisp: An old menu demonstration program. Works. zoid.lisp: Another program for interfacing with extensions. Again this extension (the "zoid extension") doesn't exist in any X server I know of. This is another obsolete file. cmucl-21a/src/clx/demo/bezier.lisp000066400000000000000000000025401260377556400172340ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX interface for Bezier Spline Extension. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (export 'draw-curves) (define-extension "bezier") (defun draw-curves (drawable gcontext points) ;; Draw Bezier splines on drawable using gcontext. ;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points)) (let* ((display (drawable-display drawable)) (opcode (extension-opcode display "bezier"))) (with-buffer-request (display opcode :gc-force gcontext) ((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier (drawable drawable) (gcontext gcontext) ((sequence :format int16) points)))) cmucl-21a/src/clx/demo/beziertest.lisp000066400000000000000000000054731260377556400201440ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX Bezier Spline Extension demo program ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) ;; Display the part picture in /extensions/test/datafile (let* ((display (open-display host)) (width 800) (height 800) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press) :x 20 :y 20 :width width :height height)) (gc (create-gcontext :drawable win :background black :foreground white)) (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) ;; Read the data (with-open-file (stream pathname) (loop (case (read-char stream nil :eof) (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) ((#\space #\newline #\tab)) (otherwise (return))))) ;; The data points were created to fit in a 2048x2048 square, ;; this means scale_factor will always be small enough so that ;; we don't need to worry about overflows. (let ((factor (ash (min width height) 5))) (dotimes (i (length lines)) (setf (aref lines i) (ash (* (aref lines i) factor) -16))) (dotimes (i (length curves)) (setf (aref curves i) (ash (* (aref curves i) factor) -16)))) (map-window win) ; Map the window ;; Handle events (unwind-protect (loop (event-case (display :force-output-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window) (draw-segments win gc lines) (draw-curves win gc curves) (draw-glyphs win gc 10 10 "Press any key to exit") ;; Returning non-nil causes event-case to exit t)) (key-press () (return-from bezier-test t)))) (close-display display)))) cmucl-21a/src/clx/demo/clclock.lisp000066400000000000000000000043371260377556400173740ustar00rootroot00000000000000#+cmu (ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XCLCLOCK" (:use "CL") (:export "CLOCK")) (in-package "XCLCLOCK") (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) (defvar *colormap* (xlib:screen-default-colormap *screen*)) (defvar *font* (xlib:open-font *display* "fixed")) (defvar *win*) (multiple-value-bind (width ascent) (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII") (setq *win* (xlib:create-window :parent (xlib:screen-root *screen*) :x 512 :y 512 :width (+ 20 width) :height (+ 20 ascent) :background (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "midnightblue"))))) (defvar *gcontext* (xlib:create-gcontext :drawable *win* :fill-style :solid :background (xlib:screen-white-pixel *screen*) :foreground (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "yellow")) :font *font*)) (defvar *background* (xlib:create-gcontext :drawable *win* :fill-style :solid :background (xlib:screen-white-pixel *screen*) :foreground (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* "midnightblue")) :font *font*)) (defvar *palette* nil) (defvar *black* (xlib:screen-black-pixel *screen*)) (defun romanize (arg) (if (zerop arg) "O" (format nil "~@R" arg))) (defun clock-string () (multiple-value-bind (s m h) (decode-universal-time (get-universal-time)) (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s)))) (defun update-clockface () (let ((string (clock-string))) (let ((string-width (xlib:text-width *gcontext* string))) (xlib:draw-rectangle *win* *background* 0 0 (xlib:drawable-width *win*) (xlib:drawable-height *win*) :fill-p) (xlib:draw-glyphs *win* *gcontext* (- (truncate (- (xlib:drawable-width *win*) string-width) 2) 10) (- (xlib:drawable-height *win*) 10) string))) (xlib:display-force-output *display*)) (defun clock () (xlib:map-window *win*) (loop (update-clockface) (sleep 1))) cmucl-21a/src/clx/demo/clipboard.lisp000066400000000000000000000207751260377556400177250ustar00rootroot00000000000000;;; This is a pretty direct translation of the Xlib selection test ;;; program by Tor Andersson found at ;;; , with ;;; minor enhancements: ;;; ;;; * gdk requestors apparently unconditionally request UTF8_STRING ;;; selections without checking the TARGETS list of the selection ;;; owner -- and apparently even never request anything else. This ;;; seems to be in contradiction with the freedesktop.org draft ;;; specification at ;;; ;;; (linked from ), but this is ;;; the real world and we have to live in it. It would be nice if ;;; someone in the freedesktop community could resolve this. ;;; ;;; * the original C code, in the XSendEvent call, has an event mask ;;; of SelectionNotify. SelectionNotify is not an event mask at ;;; all, however: but the code works "by accident" because ;;; SelectionNotify happens to have value 31, which has enough bits ;;; flipped on that most clients select on at least one of those ;;; events. This bug is fixed below. ;;; ;;; * [ Update 2004-11-29, superseding to some extent the above ] in ;;; fact, these two things are related. ICCCM says that the event ;;; disclaiming the ability to send in a given format should be sent ;;; with an empty event mask ("2.2 Responsibilities of the Selection ;;; Owner"). ;;; ;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets ;;; ;;; As ever with these things, the divisions in intellectual property ;;; between the writer of the original C program, Tor Andersson ;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the ;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk) ;;; are murky, probably depend on jurisdiction, and in addition for ;;; such a small work are essentially trivial. To set peoples' minds ;;; at ease, Tor wishes this information to be disseminated as widely ;;; as possible. ;;; Copyright (c) 2004, Christophe Rhodes ;;; ;;; 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 AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. #+cmu (ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "CLIPBOARD" (:use "CL" "XLIB") (:export "MAIN")) (in-package "CLIPBOARD") ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming ;;; was secondary to achieving First Paste. (defvar *window*) (defvar *time*) (defvar *display*) (defun ownselect () (format t "~&> set-selection-owner~%") (finish-output) (set-selection-owner *display* :primary *window* *time*) (unless (eq *window* (selection-owner *display* :primary)) (write-string "failed to own primary"))) (defun deselect () (format t "~&> unset-selection-owner~%") (finish-output) (set-selection-owner *display* :primary nil *time*) (unless (eq nil (selection-owner *display* :primary)) (write-string "failed to disown primary"))) (defun ask-paste () (format t "~&! deleting properties on window~%") (finish-output) (delete-property *window* :aeclip-target) (delete-property *window* :aeclip-string) (delete-property *window* :aeclip-utf8_string) (delete-property *window* :aeclip-text) (format t "~&> convert-selection TARGETS~%") (finish-output) (convert-selection :primary :targets *window* :aeclip-target) (format t "~&> convert-selection STRING~%") (finish-output) (convert-selection :primary :string *window* :aeclip-string) (format t "~&> convert-selection UTF8_STRING~%") (finish-output) (convert-selection :primary :utf8_string *window* :aeclip-utf8_string) (format t "~&> convert-selection TEXT~%") (finish-output) (convert-selection :primary :text *window* :aeclip-text) nil) (defun recv-paste (property) (multiple-value-bind (data name format) (get-property *window* property) (format t "~&< get-prop ~S " name) (case format (32 (format t "[~{~S~^,~}]" (mapcar (lambda (x) (atom-name *display* x)) data))) (8 (format t "~S" (map 'string 'code-char data))) (t (format t "format=~S data=~S" format data))) (format t "~%") (finish-output) (delete-property *window* property))) (defun send-copy (selection target property requestor time) (flet ((send (target property) (case target ((:string) (format t "~&> sending text data~%") (finish-output) (change-property requestor property "Hello, World (from the CLX clipboard)!" target 8 :transform #'char-code) property) (:targets (format t "~&> sending targets list~%") (finish-output) ;; ARGH. Can't use :TRANSFORM as we scribble over CLX's buffer. (let ((targets (mapcar (lambda (x) (intern-atom *display* x)) '(:targets :timestamp :multiple :string)))) (change-property requestor property targets target 32)) property) (:timestamp (format t "~&> sending timestamp~%") (finish-output) (change-property requestor property (list *time*) target 32) property) (t (format t "~&> sending none~%") (finish-output) nil)))) (case target ;; WARNING: this is untested. I don't know of any clients which ;; use the :MULTIPLE target. (:multiple (let* ((list (get-property requestor property)) (plist (mapcar (lambda (x) (atom-name *display* x)) list))) (loop for (ptarget pproperty) on plist by #'cddr with all-succeeded = t if (send ptarget pproperty) collect ptarget into result and collect pproperty into result else collect nil into result and collect pproperty into result and do (setf all-succeeded nil) finally (unless all-succeeded (let ((new-list (mapcar (lambda (x) (intern-atom *display* x)) result))) (change-property requestor property new-list target 32)))))) (t (setf property (send target property)))) (send-event requestor :selection-notify (make-event-mask) :selection selection :target target :property property :time time :event-window requestor :window requestor))) (defun main () (let* ((*display* (open-default-display)) (screen (display-default-screen *display*)) (*window* (create-window :parent (screen-root screen) :x 10 :y 10 :width 200 :height 200 :event-mask (make-event-mask :button-press :property-change)))) (map-window *window*) (display-finish-output *display*) (event-case (*display*) (:button-press (code time) (format t "~&ButtonPress~%") (finish-output) (case code (1 (setf *time* time) (ownselect)) (2 (ask-paste)) (3 (deselect)))) (:client-message () (format t "~&ClientMessage~%") (finish-output)) (:selection-clear (selection) (format t "~&SelectionClear ~S~%" selection) (finish-output)) (:selection-notify (selection target property) (format t "~&SelectionNotify ~S ~S ~S~%" selection target property) (finish-output) (unless (eq property nil) (recv-paste property)) (display-finish-output *display*)) (:selection-request (selection target property requestor time) (format t "~&SelectionRequest ~S ~S ~S~%" selection target property) (finish-output) (send-copy selection target property requestor time) (display-finish-output *display*)) (:property-notify (atom state) (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output))))) cmucl-21a/src/clx/demo/clx-demos.lisp000066400000000000000000001046471260377556400176620ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Demos -*- ;;; ;;; This file contains various graphics hacks written and ported over the ;;; years by various and numerous persons. ;;; ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; #+cmu (ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :demos (:use :common-lisp) (:export do-all-demos demo)) (in-package :demos) ;;;; Graphic demos wrapper macro. ;;; This wrapper macro should be reconsidered with respect to its property ;;; list usage. Possibly a demo structure should be used with *demos* ;;; pointing to these instead of function names. Also, something should ;;; be done about a title window that displays the name of the demo while ;;; it is running. (defparameter *demos* nil) (defvar *display* nil) (defvar *screen* nil) (defvar *root* nil) (defvar *black-pixel* nil) (defvar *white-pixel* nil) (defvar *window* nil) (defmacro defdemo (fun-name demo-name args x y width height doc &rest forms) `(progn (defun ,fun-name ,args ,doc (unless *display* #+:cmu (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) #+(or sbcl allegro clisp) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) #-(or cmu sbcl allegro clisp) (progn ;; Portable method (setf *display* (xlib:open-display (machine-instance))) (setf *screen* (xlib:display-default-screen *display*))) (setf *root* (xlib:screen-root *screen*)) (setf *black-pixel* (xlib:screen-black-pixel *screen*)) (setf *white-pixel* (xlib:screen-white-pixel *screen*))) (let ((*window* (xlib:create-window :parent *root* :x ,x :y ,y :event-mask nil :width ,width :height ,height :background *white-pixel* :border *black-pixel* :border-width 2 :override-redirect :on))) (xlib:map-window *window*) ;; ;; I hate to do this since this is not something any normal ;; program should do ... (setf (xlib:window-priority *window*) :above) (xlib:display-finish-output *display*) (unwind-protect (progn ,@forms) (xlib:unmap-window *window*) (xlib:display-finish-output *display*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) (export ',fun-name) (pushnew ',fun-name *demos*) ',fun-name)) ;;;; Main entry points. (defun do-all-demos () (loop (dolist (demo *demos*) (funcall demo) (sleep 3)))) ;;; DEMO is a hack to get by. It should be based on creating a menu. At ;;; that time, *name-to-function* should be deleted, since this mapping will ;;; be manifested in the menu slot name cross its action. Also the ;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for ;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". ;;; (defvar *name-to-function* (make-hash-table :test #'eq)) (defvar *keyword-package* (find-package "KEYWORD")) (defun demo () (macrolet ((read-demo () `(let ((*package* *keyword-package*)) (read)))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) *keyword-package*) *name-to-function*) d)) (loop (fresh-line) (dolist (d *demos*) (write-string " ") (write-line (get d 'demo-name))) (write-string " ") (write-line "Help ") (write-string " ") (write-line "Quit") (write-string "Enter demo name: ") (let ((demo (read-demo))) (case demo (:help (let* ((demo (read-demo)) (fun (gethash demo *name-to-function*))) (fresh-line) (if fun (format t "~&~%~A~&~%" (get fun 'demo-doc)) (format t "Unknown demo name -- ~A." demo)))) (:quit (return t)) (t (let ((fun (gethash demo *name-to-function*))) (if fun #+mp (mp:make-process #'(lambda () (loop (funcall fun) (sleep 2))) :name (format nil "~S" demo)) #-mp (funcall fun) (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) ;;;; Shared demo utilities. (defun full-window-state (w) (xlib:with-state (w) (values (xlib:drawable-width w) (xlib:drawable-height w) (xlib:drawable-x w) (xlib:drawable-y w) (xlib:window-map-state w)))) ;;;; Greynetic. ;;; GREYNETIC displays random sized and shaded boxes in a window. This is ;;; real slow. It needs work. ;;; (defun greynetic (window duration) (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 :drawable window)) (gcontext (xlib:create-gcontext :drawable window :background *white-pixel* :foreground *black-pixel* :tile pixmap :fill-style :tiled))) (multiple-value-bind (width height) (full-window-state window) (dotimes (i duration) (let* ((pixmap-data (greynetic-pixmapper)) (image (xlib:create-image :width 32 :height 32 :depth 1 :data pixmap-data))) (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) (xlib:draw-rectangle window gcontext (- (random width) 5) (- (random height) 5) (+ 4 (random (truncate width 3))) (+ 4 (random (truncate height 3))) t)) (xlib:display-force-output *display*))) (xlib:free-gcontext gcontext) (xlib:free-pixmap pixmap))) (defvar *greynetic-pixmap-array* (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) (defun greynetic-pixmapper () (let ((pixmap-data *greynetic-pixmap-array*)) (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) (setf nibble (logior nibble (ash nibble 4)) nibble (logior nibble (ash nibble 8)) nibble (logior nibble (ash nibble 12)) nibble (logior nibble (ash nibble 16))) (dotimes (j 32) (let ((bit (if (logbitp j nibble) 1 0))) (setf (aref pixmap-data i j) bit (aref pixmap-data (+ 4 i) j) bit (aref pixmap-data (+ 8 i) j) bit (aref pixmap-data (+ 12 i) j) bit (aref pixmap-data (+ 16 i) j) bit (aref pixmap-data (+ 20 i) j) bit (aref pixmap-data (+ 24 i) j) bit (aref pixmap-data (+ 28 i) j) bit))))) pixmap-data)) #+nil (defdemo greynetic-demo "Greynetic" (&optional (duration 300)) 100 100 600 600 "Displays random grey rectangles." (greynetic *window* duration)) ;;;; Qix. (defstruct qix buffer (dx1 5) (dy1 10) (dx2 10) (dy2 5)) (defun construct-qix (length) (let ((qix (make-qix))) (setf (qix-buffer qix) (make-circular-list length)) qix)) (defun make-circular-list (length) (let ((l (make-list length))) (rplacd (last l) l))) (defun qix (window lengths duration) "Each length is the number of lines to put in a qix, and that many qix (of the correct size) are put up on the screen. Lets the qix wander around the screen for Duration steps." (let ((histories (mapcar #'construct-qix lengths))) (multiple-value-bind (width height) (full-window-state window) (declare (fixnum width height)) (xlib:clear-area window) (xlib:display-force-output *display*) (do ((h histories (cdr h)) (l lengths (cdr l))) ((null h)) (do ((x (qix-buffer (car h)) (cdr x)) (i 0 (1+ i))) ((= i (car l))) (rplaca x (make-array 4)))) ;; Start each qix at a random spot on the screen. (dolist (h histories) (let ((x (random width)) (y (random height))) (rplaca (qix-buffer h) (make-array 4 :initial-contents (list x y x y))))) (rplacd (last histories) histories) (let ((x1 0) (y1 0) (x2 0) (y2 0) (dx1 0) (dy1 0) (dx2 0) (dy2 0) tem line next-line qix (gc (xlib:create-gcontext :drawable window :foreground *white-pixel* :background *black-pixel* :line-width 0 :line-style :solid :function boole-c2))) (declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2)) (dotimes (i duration) ;; Line is the next line in the next qix. Rotate this qix and ;; the qix ring. (setq qix (car histories)) (setq line (car (qix-buffer qix))) (setq next-line (cadr (qix-buffer qix))) (setf (qix-buffer qix) (cdr (qix-buffer qix))) (setq histories (cdr histories)) (setf x1 (svref line 0)) (setf y1 (svref line 1)) (setf x2 (svref line 2)) (setf y2 (svref line 3)) (xlib:draw-line window gc x1 y1 x2 y2) (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1)) (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1)) (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1)) (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1)) (cond ((> dx1 10) (setq dx1 10)) ((< dx1 -10) (setq dx1 -10))) (cond ((> dy1 10) (setq dy1 10)) ((< dy1 -10) (setq dy1 -10))) (cond ((> dx2 10) (setq dx2 10)) ((< dx2 -10) (setq dx2 -10))) (cond ((> dy2 10) (setq dy2 10)) ((< dy2 -10) (setq dy2 -10))) (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem)) (setq dx1 (- dx1)))) (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem)) (setq dx2 (- dx2)))) (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem)) (setq dy1 (- dy1)))) (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem)) (setq dy2 (- dy2)))) (setf (qix-dy2 qix) dy2) (setf (qix-dx2 qix) dx2) (setf (qix-dy1 qix) dy1) (setf (qix-dx1 qix) dx1) ` (when (svref next-line 0) (xlib:draw-line window gc (svref next-line 0) (svref next-line 1) (svref next-line 2) (svref next-line 3))) (setf (svref next-line 0) (+ x1 dx1)) (setf (svref next-line 1) (+ y1 dy1)) (setf (svref next-line 2) (+ x2 dx2)) (setf (svref next-line 3) (+ y2 dy2)) (xlib:display-force-output *display*)))))) (defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000)) 0 0 700 700 "Hypnotic wandering lines." (qix *window* lengths duration)) ;;;; Petal. ;;; Fast sine constants: (defconstant d360 #o5500) (defconstant d270 #o4160) (defconstant d180 #o2640) (defconstant d90 #o1320) (defconstant vecmax 2880) (defparameter sin-array '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145 #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 #o12743 #o13357 #o13771 #o14401 #o15007 #o15414 #o16016 #o16416 #o17013 #o17407 #o20000 #o20366 #o20752 #o21333 #o21711 #o22265 #o22636 #o23204 #o23546 #o24106 #o24443 #o24774 #o25323 #o25645 #o26165 #o26501 #o27011 #o27316 #o27617 #o30115 #o30406 #o30674 #o31156 #o31434 #o31706 #o32154 #o32416 #o32654 #o33106 #o33333 #o33554 #o33771 #o34202 #o34406 #o34605 #o35000 #o35167 #o35351 #o35526 #o35677 #o36043 #o36203 #o36336 #o36464 #o36605 #o36721 #o37031 #o37134 #o37231 #o37322 #o37407 #o37466 #o37540 #o37605 #o37646 #o37701 #o37730 #o37751 #o37766 #o37775 #o40000)) (defmacro psin (val) `(let* ((val ,val) neg frac sinlo) (if (>= val d180) (setq neg t val (- val d180))) (if (>= val d90) (setq val (- d180 val))) (setq frac (logand val 7)) (setq val (ash val -3)) ;; (setq sinlo (if (>= val 90) (svref sin-array 90) (svref sin-array val))) ;; (if (< val 90) (setq sinlo (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo)) -3)))) ;; (if neg (- sinlo) sinlo))) (defmacro pcos (x) `(let ((tmp (- ,x d270))) (psin (if (minusp tmp) (+ tmp d360) tmp)))) ;;;; Miscellaneous petal hackery. (defmacro high-16bits-* (a b) `(let ((a-h (ash ,a -8)) (b-h (ash ,b -8))) (+ (* a-h b-h) (ash (* a-h (logand ,b 255)) -8) (ash (* b-h (logand ,a 255)) -8)))) (defun complete (style petal) (let ((repnum 1) factor cntval needed) (dotimes (i 3) (case i (0 (setq factor 2 cntval 6)) (1 (setq factor 3 cntval 2)) (2 (setq factor 5 cntval 1))) (do () ((or (minusp cntval) (not (zerop (rem style factor))))) (setq repnum (* repnum factor)) (setq cntval (1- cntval)) (setq style (floor style factor)))) (setq needed (floor vecmax repnum)) (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed))) ;;;; Petal Parameters and Petal itself (defparameter continuous t) (defparameter styinc 2) (defparameter petinc 1) (defparameter scalfac-fac 8192) (defun petal (petal-window &optional (how-many 10) (style 0) (petal 0)) (let ((width 512) (height 512)) (xlib:clear-area petal-window) (xlib:display-force-output *display*) (let ((veccnt 0) (nustyle 722) (nupetal 3) (scalfac (1+ (floor scalfac-fac (min width height)))) (ctrx (floor width 2)) (ctry (floor height 2)) (tt 0) (s 0) (lststyle 0) (lstpetal 0) (petstyle 0) (vectors 0) (r 0) (x1 0) (y1 0) (x2 0) (y2 0) (i 0) (gc (xlib:create-gcontext :drawable petal-window :foreground *black-pixel* :background *white-pixel* :line-width 0 :line-style :solid))) (loop (when (zerop veccnt) (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal style nustyle petstyle (rem (* petal style) d360) vectors (complete style petal)) (when continuous (setq nupetal (+ nupetal petinc) nustyle (+ nustyle styinc))) (when (or (/= lststyle style) (/= lstpetal petal)) (xlib:clear-area petal-window) (xlib:display-force-output *display*))) (when (or (/= lststyle style) (/= lstpetal petal)) (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2 tt (rem (+ tt style) d360) s (rem (+ s petstyle) d360) r (pcos s)) (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac)) y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac))) (when (/= i 1) (xlib:draw-line petal-window gc x1 y1 x2 y2) (xlib:display-force-output *display*))) (when (> veccnt vectors) (setq veccnt 0) (setq how-many (1- how-many)) (sleep 2) (when (zerop how-many) (return))))))) (defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0)) 100 100 512 512 "Flower-like display." (petal *window* how-many style petal)) ;;;; Hanoi. ;;; Random parameters: (defparameter disk-thickness 15 "The thickness of a disk in pixels.") (defparameter disk-spacing (+ disk-thickness 3) "The amount of vertical space used by a disk on a needle.") (defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.") (defvar *vertical-velocity* 12 "The speed at which disks move up and down.") ;;; These variables are bound by the main function. (defvar *hanoi-window* () "The window that Hanoi is happening on.") (defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.") (defvar *transfer-height* () "The height at which disks are transferred.") (defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.") ;;; Needle Functions (defstruct disk size) (defstruct needle position disk-stack) ;;; Needle-Top-Height returns the height of the top disk on NEEDLE. (defun needle-top-height (needle) (- *hanoi-window-height* (* disk-spacing (length (the list (needle-disk-stack needle)))))) (defvar available-disks (do ((i 10 (+ i 10)) (dlist () (cons (make-disk :size i) dlist))) ((> i 80) dlist))) (defvar needle-1 (make-needle :position 184)) (defvar needle-2 (make-needle :position 382)) (defvar needle-3 (make-needle :position 584)) ;;; Graphic interface abstraction: ;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p" ;;; set to T. Update-Screen forces the display output. ;;; (defmacro invert-rectangle (x y height width) `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext* ,x ,y ,width ,height t)) (defmacro update-screen () `(xlib:display-force-output *display*)) ;;;; Moving disks up and down ;;; Slide-Up slides the image of a disk up from the coordinates X, ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to ;;; move. START-Y must be greater than END-Y (defun slide-up (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- start-y end-y) *vertical-velocity*) (do ((x (- x disk-size)) (width (* disk-size 2)) (old-y start-y (- old-y *vertical-velocity*)) (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle x (- old-y pixels-left) disk-thickness width) (invert-rectangle x old-y disk-thickness width) (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle x old-y disk-thickness width) (invert-rectangle x new-y disk-thickness width) (update-screen)))) ;;; Slide-Down slides the image of a disk down from the coordinates X, ;;; START-Y to the point X, END-Y. DISK-SIZE is the size of the disk to ;;; move. START-Y must be less than END-Y. (defun slide-down (start-y end-y x disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- end-y start-y) *vertical-velocity*) (do ((x (- x disk-size)) (width (* disk-size 2)) (old-y start-y (+ old-y *vertical-velocity*)) (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle x (+ old-y pixels-left) disk-thickness width) (invert-rectangle x old-y disk-thickness width) (update-screen))) ;; Loop body writes disk at new height & erases at old height. (invert-rectangle X old-y disk-thickness width) (invert-rectangle X new-y disk-thickness width) (update-screen)))) ;;;; Lifting and Droping Disks ;;; Lift-disk pops the top disk off of needle and raises it up to the ;;; transfer height. The disk is returned. (defun lift-disk (needle) "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it." (let* ((height (needle-top-height needle)) (disk (pop (needle-disk-stack needle)))) (slide-up height *transfer-height* (needle-position needle) (disk-size disk)) disk)) ;;; Drop-disk drops a disk positioned over needle at the transfer height ;;; onto needle. The disk is pushed onto needle. (defun drop-disk (disk needle) "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (push disk (needle-disk-stack needle)) (slide-down *transfer-height* (needle-top-height needle) (needle-position needle) (disk-size disk)) t) ;;; Drop-initial-disk is the same as drop-disk except that the disk is ;;; drawn once before dropping. (defun drop-initial-disk (disk needle) "DISK must be positioned above NEEDLE. It is dropped onto NEEDLE." (let* ((size (disk-size disk)) (lx (- (needle-position needle) size))) (invert-rectangle lx *transfer-height* disk-thickness (* size 2)) (push disk (needle-disk-stack needle)) (slide-down *transfer-height* (needle-top-height needle) (needle-position needle) (disk-size disk)) t)) ;;;; Sliding Disks Right and Left ;;; Slide-Right slides the image of a disk located at START-X, Y to the ;;; position END-X, Y. DISK-SIZE is the size of the disk. START-X is ;;; less than END-X. (defun slide-right (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- end-x start-x) *horizontal-velocity*) (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*)) (left-x (- start-x disk-size) (+ left-x *horizontal-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (invert-rectangle right-x Y disk-thickness pixels-left) (invert-rectangle left-x Y disk-thickness pixels-left) (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to right ;; side of disk, then chops off left side. (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) (update-screen)))) ;;; Slide-Left is the same as Slide-Right except that START-X is greater ;;; than END-X. (defun slide-left (start-x end-x Y disk-size) (multiple-value-bind (number-moves pixels-left) (truncate (- start-x end-x) *horizontal-velocity*) (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*) (- right-x *horizontal-velocity*)) (left-x (- (- start-x disk-size) *horizontal-velocity*) (- left-x *horizontal-velocity*)) (number-moves number-moves (1- number-moves))) ((zerop number-moves) (when (plusp pixels-left) (setq left-x (- (+ left-x *horizontal-velocity*) pixels-left)) (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left)) (invert-rectangle left-x Y disk-thickness pixels-left) (invert-rectangle right-x Y disk-thickness pixels-left) (update-screen))) ;; Loop body adds chunk *horizontal-velocity* pixels wide to left ;; side of disk, then chops off right side. (invert-rectangle left-x Y disk-thickness *horizontal-velocity*) (invert-rectangle right-x Y disk-thickness *horizontal-velocity*) (update-screen)))) ;;;; Transferring Disks ;;; Transfer disk slides a disk at the transfer height from a position ;;; over START-NEEDLE to a position over END-NEEDLE. Modified disk is ;;; returned. (defun transfer-disk (disk start-needle end-needle) "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE." (let ((start (needle-position start-needle)) (end (needle-position end-needle))) (if (< start end) (slide-right start end *transfer-height* (disk-size disk)) (slide-left start end *transfer-height* (disk-size disk))) disk)) ;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE. (defun move-one-disk (start-needle end-needle) "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE." (drop-disk (transfer-disk (lift-disk start-needle) start-needle end-needle) end-needle) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE ;;; obeying the rules of the towers of hannoi problem. To move the ;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage. (defun move-n-disks (n start-needle end-needle temp-needle) "Moves the top N disks from START-NEEDLE to END-NEEDLE. Uses TEMP-NEEDLE for temporary storage." (cond ((= n 1) (move-one-disk start-needle end-needle)) (t (move-n-disks (1- n) start-needle temp-needle end-needle) (move-one-disk start-needle end-needle) (move-n-disks (1- n) temp-needle end-needle start-needle))) t) ;;;; Hanoi itself. (defun hanoi (window n) (multiple-value-bind (width height) (full-window-state window) (declare (ignore width)) (let* ((*hanoi-window* window) (*hanoi-window-height* height) (*transfer-height* (- height (* disk-spacing n))) (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window* :foreground *white-pixel* :background *black-pixel* :fill-style :solid :function boole-c2))) (xlib:clear-area *hanoi-window*) (xlib:display-force-output *display*) (let ((needle-1 (make-needle :position 184)) (needle-2 (make-needle :position 382)) (needle-3 (make-needle :position 584))) (setf (needle-disk-stack needle-1) ()) (setf (needle-disk-stack needle-2) ()) (setf (needle-disk-stack needle-3) ()) (do ((n n (1- n)) (available-disks available-disks (cdr available-disks))) ((zerop n)) (drop-initial-disk (car available-disks) needle-1)) (move-n-disks n needle-1 needle-3 needle-2) t)))) ;;; Change the names of these when the DEMO loop isn't so stupid. ;;; (defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4)) 0 100 768 300 "Solves the Towers of Hanoi problem before your very eyes." (let ((*horizontal-velocity* 3) (*vertical-velocity* 1)) (hanoi *window* how-many))) ;;; (defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7)) 0 100 768 300 "Solves the Towers of Hanoi problem before your very eyes." (hanoi *window* how-many)) ;;;; Bounce window. ;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of ;;; the screen. Optionally, the window can have an initial x velocity, ;;; screen border elasticity, and gravity value. The outer loop is ;;; entered the first time with the window at its initial height, but ;;; each iteration after this, the loop starts with the window at the ;;; bottom of the screen heading upward. The inner loop, except for the ;;; first execution, carries the window up until the negative velocity ;;; becomes positive, carrying the window down to bottom when the ;;; velocity is positive. Due to number lossage, ROUND'ing and ;;; TRUNC'ing when the velocity gets so small will cause the window to ;;; head upward with the same velocity over two iterations which will ;;; cause the window to bounce forever, so we have prev-neg-velocity and ;;; number-problems to check for this. This is not crucial with the x ;;; velocity since the loop terminates as a function of the y velocity. ;;; (defun bounce-window (window &optional (x-velocity 0) (elasticity 0.85) (gravity 2)) (unless (< 0 elasticity 1) (error "Elasticity must be between 0 and 1.")) (unless (plusp gravity) (error "Gravity must be positive.")) (multiple-value-bind (width height x y mapped) (full-window-state window) (when (eq mapped :viewable) (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height)) (left-of-window-at-right (- (xlib:drawable-width *root*) width)) (y-velocity 0) (prev-neg-velocity most-negative-fixnum) (number-problems nil)) (declare (fixnum top-of-window-at-bottom left-of-window-at-right y-velocity)) (loop (when (= prev-neg-velocity 0) (return t)) (let ((negative-velocity (minusp y-velocity))) (loop (let ((next-y (+ y y-velocity)) (next-y-velocity (+ y-velocity gravity))) (declare (fixnum next-y next-y-velocity)) (when (> next-y top-of-window-at-bottom) (cond (number-problems (setf y-velocity (incf prev-neg-velocity))) (t (setq y-velocity (- (truncate (* elasticity y-velocity)))) (when (= y-velocity prev-neg-velocity) (incf y-velocity) (setf number-problems t)) (setf prev-neg-velocity y-velocity))) (setf y top-of-window-at-bottom) (setf (xlib:drawable-x window) x (xlib:drawable-y window) y) (xlib:display-force-output *display*) (return)) (setq y-velocity next-y-velocity) (setq y next-y)) (when (and negative-velocity (>= y-velocity 0)) (setf negative-velocity nil)) (let ((next-x (+ x x-velocity))) (declare (fixnum next-x)) (when (or (> next-x left-of-window-at-right) (< next-x 0)) (setq x-velocity (- (truncate (* elasticity x-velocity))))) (setq x next-x)) (setf (xlib:drawable-x window) x (xlib:drawable-y window) y) (xlib:display-force-output *display*)))))))) ;;; Change the name of this when DEMO is not so stupid. ;;; (defdemo shove-bounce-demo "Shove-bounce" () 100 100 300 300 "Drops the demo window with an inital X velocity which bounces off screen borders." (bounce-window *window* 30)) (defdemo bounce-demo "Bounce" () 100 100 300 300 "Drops the demo window which bounces off screen borders." (bounce-window *window*)) ;;;; Recurrence Demo ;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu) ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; The author provides this software "as is" without express or ;;; implied warranty. ;;; This routine plots the recurrence ;;; x <- y(1+sin(0.7x)) - 1.2(|x|)^.5 ;;; y <- .21 - x ;;; As described in a ?? 1983 issue of the Mathematical Intelligencer (defun recurrence (display window &optional (point-count 10000)) (let ((gc (xlib:create-gcontext :drawable window :background *white-pixel* :foreground *black-pixel*))) (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) (xlib:display-force-output display) (sleep 4)) (xlib:free-gcontext gc))) ;;; Draw points. X assumes points are in the range of width x height, ;;; with 0,0 being upper left and 0,H being lower left. ;;; hw and hh are half-width and half-height of screen (defun draw-ppict (win gc count x y hw hh) "Recursively draw pretty picture" (unless (zerop count) (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture (yf (floor (* (+ 0.7 y) hh )))) (xlib:draw-point win gc xf yf) (draw-ppict win gc (1- count) (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x)))) (- 0.21 x) hw hh)))) (defdemo recurrence-demo "Recurrence" () 10 10 700 700 "Plots a cool recurrence relation." (recurrence *display* *window*)) ;;;; Plaid ;;; ;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover. ;;; (defmacro rect-x (rects n) `(svref ,rects (ash ,n 2))) (defmacro rect-y (rects n) `(svref ,rects (+ (ash ,n 2) 1))) (defmacro rect-width (rects n) `(svref ,rects (+ (ash ,n 2) 2))) (defmacro rect-height (rects n) `(svref ,rects (+ (ash ,n 2) 3))) (defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10)) (let ((gcontext (xlib:create-gcontext :drawable window :function boole-c2 :plane-mask (logxor *white-pixel* *black-pixel*) :background *white-pixel* :foreground *black-pixel* :fill-style :solid)) (rectangles (make-array (* 4 num-rectangles) :element-type 'number :initial-element 0))) (multiple-value-bind (width height) (full-window-state window) (let ((center-x (ash width -1)) (center-y (ash height -1)) (x-dir -2) (y-dir -2) (x-off 2) (y-off 2)) (dotimes (iter (truncate num-iterations num-rectangles)) (dotimes (i num-rectangles) (setf (rect-x rectangles i) (- center-x x-off)) (setf (rect-y rectangles i) (- center-y y-off)) (setf (rect-width rectangles i) (ash x-off 1)) (setf (rect-height rectangles i) (ash y-off 1)) (incf x-off x-dir) (incf y-off y-dir) (when (or (<= x-off 0) (>= x-off center-x)) (decf x-off (ash x-dir 1)) (setf x-dir (- x-dir))) (when (or (<= y-off 0) (>= y-off center-y)) (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) (defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10)) 10 10 101 201 "Plaid, man." (plaid *display* *window* iterations num-rectangles)) ;;;; Bball demo ;;; ;;; Ported to CLX by Blaine Burks ;;; (defvar *ball-size-x* 38) (defvar *ball-size-y* 34) (defmacro xor-ball (pixmap window gcontext x y) `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* ,window ,x ,y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) (defvar *max-bball-x*) (defvar *max-bball-y*) (defstruct ball (x (random (- *max-bball-x* *ball-size-x*))) (y (random (- *max-bball-y* *ball-size-y*))) (dx (if (zerop (random 2)) (random maximum-x-drift) (- (random maximum-x-drift)))) (dy 0)) (defun get-bounce-image () "Returns the pixmap to be bounced around the screen." (xlib::bitmap-image #*000000000000000000000000000000000000 #*000000000000000000000000000000000000 #*000000000000000000001000000010000000 #*000000000000000000000000000100000000 #*000000000000000000000100001000000000 #*000000000000000010000000010000000000 #*000000000000000000100010000000000000 #*000000000000000000001000000000000000 #*000000000001111100000000000101010000 #*000000000010000011000111000000000000 #*000000000100000000111000000000000000 #*000000000100000000000000000100000000 #*000000000100000000001000100010000000 #*000000111111100000010000000001000000 #*000000111111100000100000100000100000 #*000011111111111000000000000000000000 #*001111111111111110000000100000000000 #*001111111111111110000000000000000000 #*011111111111111111000000000000000000 #*011111111111111111000000000000000000 #*111111111111110111100000000000000000 #*111111111111111111100000000000000000 #*111111111111111101100000000000000000 #*111111111111111101100000000000000000 #*111111111111111101100000000000000000 #*111111111111111111100000000000000000 #*111111111111110111100000000000000000 #*011111111111111111000000000000000000 #*011111111111011111000000000000000000 #*001111111111111110000000000000000000 #*001111111111111110000000000000000000 #*000011111111111000000000000000000000 #*000000111111100000000000000000000000 #*000000000000000000000000000000000000)) (defun bounce-1-ball (pixmap window gcontext ball) (let ((x (ball-x ball)) (y (ball-y ball)) (dx (ball-dx ball)) (dy (ball-dy ball))) (xor-ball pixmap window gcontext x y) (setq x (+ x dx)) (setq y (+ y dy)) (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*))) (setq x (- x dx) dx (- dx))) (if (> y (- *max-bball-y* *ball-size-y*)) (setq y (- y dy) dy (- dy))) (setq dy (+ dy bball-gravity)) (setf (ball-x ball) x) (setf (ball-y ball) y) (setf (ball-dx ball) dx) (setf (ball-dy ball) dy) (xor-ball pixmap window gcontext x y))) (defun bounce-balls (display window how-many duration) (xlib:clear-area window) (xlib:display-force-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) (list () (cons (make-ball) list))) ((= i how-many) list))) (gcontext (xlib:create-gcontext :drawable window :foreground *white-pixel* :background *black-pixel* :function boole-xor :exposures :off)) (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1 :drawable window)) (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap :foreground *white-pixel* :background *black-pixel*))) (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image) :x 0 :y 0 :width 38 :height 34) (xlib:free-gcontext pixmap-gc) (dolist (ball balls) (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) (xlib:display-force-output display) (dotimes (i duration) (dolist (ball balls) (bounce-1-ball bounce-pixmap window gcontext ball)) (xlib:display-force-output display)) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) #+nil (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) 34 34 700 500 "Bouncing balls in space." (bounce-balls *display* *window* how-many duration)) cmucl-21a/src/clx/demo/gl-test.lisp000066400000000000000000000373161260377556400173440ustar00rootroot00000000000000#+cmu (ext:file-comment "$Id: gl-test.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :gl-test (:use :common-lisp :xlib) (:export "TEST" "CLX-TEST")) (in-package :gl-test) (defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) (let* ((display (open-display host :display display)) (screen (display-default-screen display)) (root (screen-root screen)) ctx) (unwind-protect (progn ;;; Inform the server about us. (glx::client-info display) (let* ((visual (glx:choose-visual screen '(:glx-rgba (:glx-red-size 1) (:glx-green-size 1) (:glx-blue-size 1) :glx-double-buffer))) (colormap (create-colormap (glx:visual-id visual) root)) (window (create-window :parent root :x 10 :y 10 :width width :height height :class :input-output :background (screen-black-pixel screen) :border (screen-black-pixel screen) :visual (glx:visual-id visual) :depth 24 :colormap colormap :event-mask '(:structure-notify :exposure))) (gc (create-gcontext :foreground (screen-white-pixel screen) :background (screen-black-pixel screen) :drawable window :font (open-font display "fixed")))) (set-wm-properties window :name "glx-test" :resource-class "glx-test" :command (list "glx-test") :x 10 :y 10 :width width :height height :min-width width :min-height height :initial-state :normal) (setf ctx (glx:create-context screen (glx:visual-id visual))) (map-window window) (glx:make-current window ctx) (funcall function display window) (unmap-window window) (free-gcontext gc))) (when ctx (glx:destroy-context ctx)) (close-display display)))) ;;; Tests (defun no-floats (display window) (declare (ignore display window)) (gl:color-3s #x7fff #x7fff 0) (gl:begin gl:+polygon+) (gl:vertex-2s 0 0) (gl:vertex-2s 1 0) (gl:vertex-2s 1 1) (gl:vertex-2s 0 1) (gl:end) (glx:swap-buffers) (sleep 5)) (defun anim (display window) (declare (ignore display window)) (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) (gl:line-width 2.0s0) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn (gl:clear gl:+color-buffer-bit+) (gl:push-matrix) (gl:translate-f 0.5s0 0.5s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:translate-f -0.5s0 -0.5s0 0.0s0) (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) (gl:color-3ub 255 0 0) (gl:vertex-2f 0.25s0 0.25s0) (gl:color-3ub 0 255 0) (gl:vertex-2f 0.75s0 0.25s0) (gl:color-3ub 0 0 255) (gl:vertex-2f 0.75s0 0.75s0) (gl:color-3ub 255 255 255) (gl:vertex-2f 0.25s0 0.75s0) (gl:end) (gl:pop-matrix) (glx:swap-buffers) (sleep 0.02))) (sleep 3)) (defun anim/list (display window) (declare (ignore display window)) (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) (let ((list (gl:gen-lists 1))) (gl:new-list list gl:+compile+) (gl:begin gl:+polygon+) (gl:color-3ub 255 0 0) (gl:vertex-2f 0.25s0 0.25s0) (gl:color-3ub 0 255 0) (gl:vertex-2f 0.75s0 0.25s0) (gl:color-3ub 0 0 255) (gl:vertex-2f 0.75s0 0.75s0) (gl:color-3ub 255 255 255) (gl:vertex-2f 0.25s0 0.75s0) (gl:end) (glx:render) (gl:end-list) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn (gl:clear gl:+color-buffer-bit+) (gl:push-matrix) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:call-list list) (gl:pop-matrix) (glx:swap-buffers) (sleep 0.02)))) (sleep 3)) ;;; glxgears (defconstant +pi+ (coerce pi 'single-float)) (declaim (type single-float +pi+)) (defun gear (inner-radius outer-radius width teeth tooth-depth) (let ((r0 inner-radius) (r1 (/ (- outer-radius tooth-depth) 2.0s0)) (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) (gl:shade-model gl:+flat+) (gl:normal-3f 0.0s0 0.0s0 1.0s0) ;; Front face. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (when (< i teeth) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0))))) (gl:end) ;; Draw front sides of teeth. (gl:begin gl:+quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)))) (gl:end) (gl:normal-3f 0.0s0 0.0s0 -1.0s0) ;; Draw back face. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (when (< i teeth) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))) (gl:end) ;; Draw back sides of teeth. (gl:begin gl:+quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)))) (gl:end) ;; Draw outward faces of teeth. (gl:begin gl:+quad-strip+) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setf u (/ u len) v (/ v len)) (gl:normal-3f v u 0.0s0) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) (gl:normal-3f (cos angle) (sin angle) 0.0s0) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal-3f v (- u) 0.0s0) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) (gl:end) (gl:shade-model gl:+smooth+) ;; Draw inside radius cylinder. (gl:begin gl:+quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) (gl:end))) (defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) (gl:push-matrix) (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) (gl:push-matrix) (gl:translate-f -3.0s0 -2.0s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:call-list gear-1) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f 3.1s0 -2.0s0 0.0s0) (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) (gl:call-list gear-2) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f -3.1s0 4.2s0 0.0s0) (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) (gl:call-list gear-3) (gl:pop-matrix) (gl:pop-matrix)) (defun reshape (width height) (gl:viewport 0 0 width height) (let ((h (coerce (/ height width) 'double-float))) (gl:matrix-mode gl:+projection+) (gl:load-identity) (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) (gl:matrix-mode gl:+modelview+) (gl:load-identity) (gl:translate-f 0.0s0 0.0s0 -40.0s0)) (defun init () (let (gear-1 gear-2 gear-3) ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) ;;(gl:enable gl:+cull-face+) ;;(gl:enable gl:+lighting+) ;;(gl:enable gl:+light0+) ;;(gl:enable gl:+depth-test+) ;; Make the gears. (setf gear-1 (gl:gen-lists 1)) (gl:new-list gear-1 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (gl:end-list) (setf gear-2 (gl:gen-lists 1)) (gl:new-list gear-2 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) (gl:end-list) (setf gear-3 (gl:gen-lists 1)) (gl:new-list gear-3 gl:+compile+) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) (gl:end-list) ;;(gl:enable gl:+normalize+) (values gear-1 gear-2 gear-3))) (defun gears* (display window) (declare (ignore display window)) (gl:enable gl:+cull-face+) (gl:enable gl:+lighting+) (gl:enable gl:+light0+) (gl:enable gl:+normalize+) (gl:enable gl:+depth-test+) (reshape 300 300) ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) (let (list) (declare (ignore list)) #-(and) (progn (setf list (gl:gen-lists 1)) (gl:new-list list gl:+compile+) ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (glx:render) (gl:end-list)) (loop ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 with angle single-float = 0.0s0 with dt = 0.004s0 repeat 2500 do (progn (incf angle (* 70.0s0 dt)) ; 70 degrees per second (when (< 3600.0s0 angle) (decf angle 3600.0s0)) (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) (gl:push-matrix) (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) (gl:push-matrix) (gl:translate-f -3.0s0 -2.0s0 0.0s0) (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f 3.1s0 -2.0s0 0.0s0) (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) (gl:pop-matrix) (gl:push-matrix) (gl:translate-f -3.1s0 4.2s0 0.0s0) (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) (gl:pop-matrix) (gl:pop-matrix) (glx:swap-buffers) ;;(sleep 0.025) ))) ;;(sleep 3) ) (defun gears (display window) (declare (ignore window)) (let ((view-rotx 20.0s0) (view-roty 30.0s0) (view-rotz 0.0s0) (angle 0.0s0) (frames 0) (dt 0.004s0) ; *** This is dynamically adjusted ;;(t-rot-0 -1.0d0) ;;(t-rate-0 -1.d0) gear-1 gear-2 gear-3) (multiple-value-setq (gear-1 gear-2 gear-3) (init)) (loop (event-case (display :timeout 0.01 :force-output-p t) (configure-notify (width height) (reshape width height) t) (key-press (code) (format t "Key pressed: ~S~%" code) (return-from gears t))) (incf angle (* 70.0s0 dt)) ; 70 degrees per second (when (< 3600.0s0 angle) (decf angle 3600.0s0)) (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) (glx:swap-buffers) (incf frames) ;; FPS calculation goes here ))) cmucl-21a/src/clx/demo/hello.lisp000066400000000000000000000047521260377556400170660ustar00rootroot00000000000000;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- #+cmu (ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) ;; CLX demo, says STRING using FONT in its own window on HOST (let ((display nil) (abort t)) (unwind-protect (progn (setq display (open-display host)) (multiple-value-prog1 (let* ((screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (font (open-font display font)) (border 1) ; Minimum margin around the text (width (+ (text-width font string) (* 2 border))) (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) (x (truncate (- (screen-width screen) width) 2)) (y (truncate (- (screen-height screen) height) 2)) (window (create-window :parent (screen-root screen) :x x :y y :width width :height height :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :button-press))) (gcontext (create-gcontext :drawable window :background black :foreground white :font font))) ;; Set window manager hints (set-wm-properties window :name 'hello-world :icon-name string :resource-name string :resource-class 'hello-world :command (list* 'hello-world host args) :x x :y y :width width :height height :min-width width :min-height height :input :off :initial-state :normal) (map-window window) ; Map the window ;; Handle events (event-case (display :discard-p t :force-output-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (with-state (window) (let ((x (truncate (- (drawable-width window) width) 2)) (y (truncate (- (+ (drawable-height window) (max-char-ascent font)) (max-char-descent font)) 2))) ;; Draw text centered in widnow (clear-area window) (draw-glyphs window gcontext x y string))) ;; Returning non-nil causes event-case to exit nil)) (button-press () t))) ;; Pressing any mouse-button exits (setq abort nil))) ;; Ensure display is closed when done (when display (close-display display :abort abort))))) cmucl-21a/src/clx/demo/mandel.lisp000066400000000000000000000435711260377556400172250ustar00rootroot00000000000000#+cmu (ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage "XMANDEL" (:use "CL") (:export "NEW-WINDOW" "EVENT-LOOP")) (in-package "XMANDEL") (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) (defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id") (defvar *colmap* nil) (defvar *helpwin* nil) (defvar *zoom-table* (make-hash-table)) (defvar *zoomcolmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-white-pixel *screen*) :function boole-xor)) (defvar *white* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-white-pixel *screen*) )) (defvar *winmap* (make-hash-table)) (defvar *textmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:screen-black-pixel *screen*) :background (xlib:screen-white-pixel *screen*))) ;;; OK, this is an ugly hack to make sure we can handle ;;; shift and modstate in a sane way, alas we can't 100% rely ;;; on "current state of keyboard", since we only process events ;;; with a noticeable delay, at eth best of times, so a fast keyboarder ;;; can fool us, we are, however, IIRC, guaranteed that all events are ;;; serialised, so... (defvar *modstate* nil) (declaim (list *modstate*)) (defun make-shift-foo () (let ((rv 0)) (if (member :shift *modstate*) (setf rv 1)) (if (member :character-set-switch *modstate*) (setf rv (+ rv 2))) rv)) (defstruct (mandel-square (:conc-name ms-)) (x 0 :type fixnum) (y 0 :type fixnum) (s 512 :type fixnum) (base-r 0.0d0 :type double-float) (base-i 0.0d0 :type double-float) (maxiter 1024 :type fixnum) (dr 0.0d0 :type double-float) (di 0.0d0 :type double-float) win ) (defun make-queue (&rest args) (apply #'make-instance 'queue args)) (defclass queue () ((head :initform nil :accessor q-head) (tail :initform nil :accessor q-tail))) (defclass out-queue () ((win-queues :accessor win-queues :initarg :xyzzy-1) (seen-windows :accessor windows :initform nil) (win-list :accessor win-list :initarg :xyzzy-2) (last-window :accessor last-window :initform nil)) (:default-initargs :xyzzy-1 (make-hash-table) :xyzzy-2 (make-instance 'queue))) (defvar *sysqueue* (make-instance 'out-queue)) (defgeneric empty-p (queue)) (defgeneric empty (queue)) (defgeneric empty-win (queue win)) (defgeneric enqueue (queue item)) (defgeneric queue-push (queue item)) (defgeneric dequeue (queue)) (defmethod empty-p ((q null)) t) (defmethod empty-p ((q queue)) (null (q-head q))) (defmethod empty-p ((q out-queue)) (let ((coll nil)) (maphash #'(lambda (key val) (declare (ignore key)) (push (empty-p val) coll)) (win-queues q)) (every #'identity coll))) (defmethod empty ((q null)) nil) (defmethod empty ((q queue)) (setf (q-head q) nil) (setf (q-tail q) nil)) (defmethod empty ((q out-queue)) (maphash #'(lambda (key val) (declare (ignore key)) (empty val)) (win-queues q))) (defmethod empty-win ((q out-queue) win) (let ((temp-queue (gethash win (win-queues q)))) (empty temp-queue))) (defmethod enqueue ((q queue) item) (cond ((empty-p q) (setf (q-head q) (cons item nil)) (setf (q-tail q) (q-head q))) (t (setf (cdr (q-tail q)) (cons item nil)) (setf (q-tail q) (cdr (q-tail q)))))) (defmethod enqueue ((q out-queue) item) (let ((windows (q-head (win-list q))) (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) (unless (member win (windows q)) (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) (let ((new (make-queue))) (setf (gethash win (win-queues q)) new) (enqueue new item)) (enqueue temp-queue item))))) (defmethod queue-push ((q queue) item) (cond ((empty-p q) (setf (q-head q) (cons item nil)) (setf (q-tail q) (q-head q))) (t (setf (q-head q) (cons item (q-head q)))))) (defmethod queue-push ((q out-queue) item) (let ((windows (q-head (win-list q))) (win (ms-win item))) (declare (type xlib:window win)) (unless (member win windows) (enqueue (win-list q) win)) (unless (member win (windows q)) (push win (windows q))) (let ((temp-queue (gethash win (win-queues q)))) (if (null temp-queue) (let ((new (make-queue))) (setf (gethash win (win-queues q)) new) (queue-push new item)) (queue-push temp-queue item))))) (defmethod dequeue ((q out-queue)) (if (empty-p q) nil (let ((windows (win-list q))) (do* ((next (dequeue windows)) (finished nil) (val nil) (temp-queue (gethash next (win-queues q)) (gethash next (win-queues q)))) (finished val) (cond ((empty-p temp-queue) (setf next (dequeue windows))) (t (setf val (dequeue temp-queue)) (unless (empty-p temp-queue) (enqueue windows next)) (setf finished t))))))) (defmethod dequeue ((q queue)) (prog1 (car (q-head q)) (if (not (empty-p q)) (setf (q-head q) (cdr (q-head q)))) (if (null (q-head q)) (progn (setf (q-head q) nil) (setf (q-tail q) nil))))) (defun iter (rc ic max) (declare (double-float rc ic) (fixnum max)) (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc))) (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic))) (n 1 (the fixnum (1+ n)))) ((or (>= n max) (>= (+ (* x x) (* y y)) 4.0d0)) n))) ;;; (a+bi)^2 --> ;;; (a+bi)(a+bi) --> ;;; a^2+2abi+(bi)^2 --> ;;; a^2+2abi-b^2 (defclass zoomer () ((zoom-type :initarg :type :reader zoom-type :type fixnum) (start-x :initarg :x :reader start-x :type fixnum) (start-y :initarg :y :reader start-y :type fixnum) (stop-x :accessor stop-x :initform -1 :type fixnum) (stop-y :accessor stop-y :initform -1 :type fixnum) (win :reader win :initarg :win))) ;;;(defmethod print-object ((object zoomer) stream) ;;; (format stream " [~a ~a]>~%" ;;; (zoom-type object) (start-x object) (start-y object) ;;; (stop-x object) (stop-y object))) (defun init-colours () (unless *colmap* (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*)) (setf (aref *colmap* 0) (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:alloc-color (xlib:screen-default-colormap *screen*) (xlib:make-color :red 0 :green 0 :blue 0)))) (loop for index from 1 to 255 do (setf (aref *colmap* index) (xlib:create-gcontext :drawable (xlib:screen-root *screen*) :foreground (xlib:alloc-color (xlib:screen-default-colormap *screen*) (xlib:make-color :red (random 1.0) :green (random 1.0) :blue (random 1.0)))))))) (defmacro modcol (col max) `(if (= ,col ,max) 0 (1+ (mod ,col 255)))) (defun plot (win col x y max) (declare (fixnum col x y max)) (let ((col (modcol col max))) (xlib:draw-point win (aref *colmap* col) x y) (setf (aref (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)) x y) col))) (defun display-help () (unless *helpwin* (setf *helpwin* (xlib:create-window :parent (xlib:screen-root *screen*) :x 512 :y 512 :width 310 :height 180 :event-mask (xlib:make-event-mask :exposure) :backing-store :always :background (xlib:screen-white-pixel *screen*))) (xlib:map-window *helpwin*) (xlib:display-force-output *display*)) (unless (xlib:gcontext-font *textmap*) (let ((fixed (xlib:list-fonts *display* "fixed")) font) (if fixed (setf font (xlib:open-font *display* "fixed")) (error "Could not open suitable font")) (setf (xlib:gcontext-font *textmap*) (if (consp fixed) (car fixed) fixed)))) (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t) (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same") (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new") (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same") (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,") (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.") (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit") (xlib:display-force-output *display*)) (defun repaint-window (win x-low y-low x-high y-high) (declare (fixnum x-low y-low x-high y-high)) (if (eq win *helpwin*) (display-help) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for y of-type fixnum from y-low to y-high do (loop for x of-type fixnum from x-low to x-high do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y)))))) (defun fill-square (win col x y s max) (declare (fixnum col x y s max)) (let ((col (modcol col max))) (xlib:draw-rectangle win (aref *colmap* col) x y s s t) (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*)))) (loop for px of-type fixnum from x to (1- (+ x s)) do (loop for py of-type fixnum from y to (1- (+ y s)) do (setf (aref bs px py) col)))))) (defun make-square (win x y side bx by dx dy &optional (maxiter 1024)) (declare (xlib:window win) (fixnum x y side maxiter) (double-float bx by dx dy)) (let ((sq (make-mandel-square :x x :y y :s side :base-r bx :base-i by :dr dx :di dy :maxiter maxiter :win win))) (queue-push *sysqueue* sq))) (defun mandel-win (win lx ly hx hy &optional (maxiter 1024)) (declare (xlib:window win) (double-float lx ly hx hy) (fixnum maxiter)) (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float)) (dy (coerce (/ (- hy ly) 512.0d0) 'double-float))) (setf (gethash win *winmap*) (make-mandel-square :x 0 :y 0 :s 512 :base-r lx :base-i ly :dr dx :di dy :maxiter maxiter)) (make-square win 0 256 256 lx ly dx dy maxiter) (make-square win 256 256 256 lx ly dx dy maxiter) (make-square win 256 0 256 lx ly dx dy maxiter) (make-square win 0 0 256 lx ly dx dy maxiter))) (defun new-window (lx ly hx hy &optional (maxiter 1024)) (let ((win (xlib:create-window :parent (xlib:screen-root *screen*) :x (+ 100 (random 50)) :y (+ 100 (random 50)) :width 512 :height 512 :bit-gravity :center :event-mask (xlib:make-event-mask :button-motion :button-press :button-release :key-press :exposure))) (ar (make-array '(512 512) :element-type '(integer 0 255) :initial-element 0)) ) (setf (gethash win *backing-store*) ar) (xlib:map-window win) (mandel-win win (coerce lx 'double-float) (coerce ly 'double-float) (coerce hx 'double-float) (coerce hy 'double-float) maxiter))) (defun fill-square-p (ix iy s bx by dx dy max win) (declare (fixnum ix iy s max) (double-float bx by dx dy)) (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) (and (loop for px from ix below (+ ix s) for x of-type double-float = (+ bx (* px dx)) with y = (+ by (* iy dy)) for i = (iter x y max) do (plot win i px iy max) while (= i norm) finally (return t)) (loop for py from iy below (+ s iy) for y of-type double-float = (+ by (* py dy)) with x = (+ bx (* ix dx)) for i = (iter x y max) do (plot win i ix py max) while (= i norm) finally (return t)) (loop for px from (1- (+ s ix)) downto ix for x of-type double-float = (+ bx (* px dx)) with y = (+ by (* dy (1- (+ s iy)))) for i = (iter x y max) do (plot win i px iy max) if (/= i norm) return nil finally (return t)) (loop for py from (1- (+ s iy)) downto iy for y of-type double-float = (+ by (* py dy)) with x = (+ bx (* dx (1- (+ s ix)))) for i = (iter x y max) do (plot win i ix py max) if (/= i norm) return nil finally (return t))))) (defmacro z (base delta int) `(+ ,base (* ,delta ,int))) (defun draw-square (square) (declare (mandel-square square)) (let ((dx (ms-dr square)) (dy (ms-di square)) (base-x (ms-base-r square)) (base-y (ms-base-i square)) (maxiter (ms-maxiter square)) (win (ms-win square)) (x (ms-x square)) (y (ms-y square)) (s (ms-s square)) ) (declare (double-float dx dy base-x base-y) (fixnum x y s maxiter)) (cond ((= s 2) (plot win (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter) (1+ x) (1+ y) maxiter) (plot win (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter) (1+ x) y maxiter) (plot win (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter) x (1+ y) maxiter) (plot win (iter (z base-x dx x) (z base-y dy y) maxiter) x y maxiter)) ((fill-square-p x y s base-x base-y dx dy maxiter win) (fill-square win (iter (z base-x dx x) (z base-y dy y) maxiter) x y s maxiter)) (t (let ((new-s (/ s 2))) (make-square win x y new-s base-x base-y dx dy maxiter) (make-square win x (+ y new-s) new-s base-x base-y dx dy maxiter) (make-square win (+ x new-s) y new-s base-x base-y dx dy maxiter) (make-square win (+ x new-s) (+ y new-s) new-s base-x base-y dx dy maxiter)))))) (defun create-zoom (win x y button) (setf (gethash win *zoom-table*) (make-instance 'zoomer :x x :y y :win win :type (case button (1 :zoom-same) (2 :zoom-new) (3 :zoom-out))))) (defun update-zoom (win x y code) (declare (ignore code) (fixnum x y)) (let ((zoomer (gethash win *zoom-table*))) (when zoomer (let ((new-side (max 0 (- (the fixnum x) (the fixnum (start-x zoomer))) (- (the fixnum y) (the fixnum (start-y zoomer)))))) (let ((old-side (max 0 (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer))) (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))))) (xlib:draw-rectangle win *zoomcolmap* (the fixnum (start-x zoomer)) (the fixnum (start-y zoomer)) old-side old-side)) (setf (stop-x zoomer) (max (the fixnum (start-x zoomer)) (the fixnum x) )) (setf (stop-y zoomer) (max (the fixnum (start-y zoomer)) (the fixnum y) )) (xlib:draw-rectangle win *zoomcolmap* (the fixnum (start-x zoomer)) (the fixnum (start-y zoomer)) new-side new-side) (xlib:display-force-output *display*))))) (defun finish-zoom (win x y code) (declare (ignore code)) (let ((zoomer (gethash win *zoom-table*))) (setf (stop-x zoomer) x) (setf (stop-y zoomer) y))) (defun do-zoom (win) (let ((zoomer (gethash win *zoom-table*))) (declare (zoomer zoomer)) (setf (gethash win *zoom-table*) nil) (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer)))) (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer)))) (sq (gethash win *winmap*))) (let ((side (max dx dy)) (x (the fixnum (start-x zoomer))) (y (the fixnum (start-y zoomer))) lx hx ly hy ) (if (< side 5) (setf lx (+ (ms-base-r sq) (* (- x 128) (ms-dr sq))) ly (+ (ms-base-i sq) (* (- y 128) (ms-di sq))) hx (+ (ms-base-r sq) (* (+ x 128) (ms-dr sq))) hy (+ (ms-base-i sq) (* (+ y 128) (ms-di sq)))) (setf lx (+ (ms-base-r sq) (* x (ms-dr sq))) ly (+ (ms-base-i sq) (* y (ms-dr sq))) hx (+ (ms-base-r sq) (* (+ side x) (ms-dr sq))) hy (+ (ms-base-i sq) (* (+ side y) (ms-dr sq))))) ;;; (format t "DEBUG: zoomer is ~a~%~%" zoomer) (case (zoom-type zoomer) (:zoom-new (new-window lx ly hx hy (ms-maxiter sq))) (:zoom-same (empty-win *sysqueue* win) (mandel-win win lx ly hx hy (ms-maxiter sq))) (:zoom-out (empty-win *sysqueue* win) (let ((br (ms-base-r sq)) (bi (ms-base-i sq)) (dr (ms-dr sq)) (di (ms-di sq))) (mandel-win win (- br (* 512 dr)) (- bi (* 512 di)) (+ (* 1024 dr) br) (+ (* 1024 di) bi) (ms-maxiter sq)))) (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer)))))))) (defun quit-window (window) (let ((temp (gethash window (win-queues *sysqueue*)))) (when temp (empty temp)))) (defun event-loop () (init-colours) (do ((quit nil) (redisplay nil t)) ((eq quit 'quit)) (xlib:event-case (*display* :timeout 0) (:button-press (window x y code) (create-zoom window x y code) t) (:button-release (window x y code) (finish-zoom window x y code) (do-zoom window) t) (:motion-notify (window x y code) (update-zoom window x y code) t) (:exposure (window x y width height count) (let ((count count)) (declare (ignore count) (fixnum x y width height)) (when redisplay (repaint-window window x y (1- (+ x width)) (1- (+ y height))))) t) (:key-press (window code) (case (xlib:keysym->character *display* (xlib:keycode->keysym *display* code (make-shift-foo))) (#\q (quit-window window)) (#\? (display-help)) ((:left-shift :right-shift) (push :shift *modstate*)) ((:left-control :right-control) (push :ctrl *modstate*)) (:character-set-switch (push :character-set-switch *modstate*))) t) (:key-release (window code) (let ((window window)) (declare (ignore window)) (case (xlib:keysym->character *display* (xlib:keycode->keysym *display* code 0)) (:character-set-switch (setf *modstate* (delete :character-set-switch *modstate*))) ((:left-control :right-control) (setf *modstate* (delete :ctrl *modstate*))) ((:left-shift :right-shift) (setf *modstate* (delete :shift *modstate*))))) t)) (cond ((empty-p *sysqueue*) nil) (t (let ((square (dequeue *sysqueue*))) (draw-square square)))))) cmucl-21a/src/clx/demo/menu.lisp000066400000000000000000000276511260377556400167320ustar00rootroot00000000000000;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1988 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;;;----------------------------------------------------------------------------------+ ;;; | ;;; These functions demonstrate a simple menu implementation described in | ;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. | ;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. | ;;; | ;;;----------------------------------------------------------------------------------+ (defstruct (menu) "A simple menu of text strings." (title "choose an item:") item-alist ;((item-window item-string)) window gcontext width title-width item-width item-height (geometry-changed-p t)) ;nil iff unchanged since displayed (defun create-menu (parent-window text-color background-color text-font) (make-menu ;; Create menu graphics context :gcontext (CREATE-GCONTEXT :drawable parent-window :foreground text-color :background background-color :font text-font) ;; Create menu window :window (CREATE-WINDOW :parent parent-window :class :input-output :x 0 ;temporary value :y 0 ;temporary value :width 16 ;temporary value :height 16 ;temporary value :border-width 2 :border text-color :background background-color :save-under :on :override-redirect :on ;override window mgr when positioning :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) (defun menu-set-item-list (menu &rest item-strings) ;; Assume the new items will change the menu's width and height (setf (menu-geometry-changed-p menu) t) ;; Destroy any existing item windows (dolist (item (menu-item-alist menu)) (DESTROY-WINDOW (first item))) ;; Add (item-window item-string) elements to item-alist (setf (menu-item-alist menu) (let (alist) (dolist (item item-strings (nreverse alist)) (push (list (CREATE-WINDOW :parent (menu-window menu) :x 0 ;temporary value :y 0 ;temporary value :width 16 ;temporary value :height 16 ;temporary value :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) :event-mask (MAKE-EVENT-MASK :enter-window :leave-window :button-press :button-release)) item) alist))))) (defparameter *menu-item-margin* 4 "Minimum number of pixels surrounding menu items.") (defun menu-recompute-geometry (menu) (when (menu-geometry-changed-p menu) (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) (title-width (TEXT-EXTENTS menu-font (menu-title menu))) (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) (item-width 0) (items (menu-item-alist menu)) menu-width) ;; Find max item string width (dolist (next-item items) (setf item-width (max item-width (TEXT-EXTENTS menu-font (second next-item))))) ;; Compute final menu width, taking margins into account (setf menu-width (max title-width (+ item-width *menu-item-margin* *menu-item-margin*))) (let ((window (menu-window menu)) (delta-y (+ item-height *menu-item-margin*))) ;; Update width and height of menu window (WITH-STATE (window) (setf (DRAWABLE-WIDTH window) menu-width (DRAWABLE-HEIGHT window) (+ *menu-item-margin* (* (1+ (length items)) delta-y)))) ;; Update width, height, position of item windows (let ((item-left (round (- menu-width item-width) 2)) (next-item-top delta-y)) (dolist (next-item items) (let ((window (first next-item))) (WITH-STATE (window) (setf (DRAWABLE-HEIGHT window) item-height (DRAWABLE-WIDTH window) item-width (DRAWABLE-X window) item-left (DRAWABLE-Y window) next-item-top))) (incf next-item-top delta-y)))) ;; Map all item windows (MAP-SUBWINDOWS (menu-window menu)) ;; Save item geometry (setf (menu-item-width menu) item-width (menu-item-height menu) item-height (menu-width menu) menu-width (menu-title-width menu) title-width (menu-geometry-changed-p menu) nil)))) (defun menu-refresh (menu) (let* ((gcontext (menu-gcontext menu)) (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) ;; Show title centered in "reverse-video" (let ((fg (GCONTEXT-BACKGROUND gcontext)) (bg (GCONTEXT-FOREGROUND gcontext))) (WITH-GCONTEXT (gcontext :foreground fg :background bg) (DRAW-IMAGE-GLYPHS (menu-window menu) gcontext (round (- (menu-width menu) (menu-title-width menu)) 2) ;start x baseline-y ;start y (menu-title menu)))) ;; Show each menu item (position is relative to item window) (dolist (item (menu-item-alist menu)) (DRAW-IMAGE-GLYPHS (first item) gcontext 0 ;start x baseline-y ;start y (second item))))) (defun menu-choose (menu x y) ;; Display the menu so that first item is at x,y. (menu-present menu x y) (let ((items (menu-item-alist menu)) (mw (menu-window menu)) selected-item) ;; Event processing loop (do () (selected-item) (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) (:exposure (count) ;; Discard all but final :exposure then display the menu (when (zerop count) (menu-refresh menu)) t) (:button-release (event-window) ;;Select an item (setf selected-item (second (assoc event-window items))) t) (:enter-notify (window) ;;Highlight an item (let ((position (position window items :key #'first))) (when position (menu-highlight-item menu position))) t) (:leave-notify (window kind) (if (eql mw window) ;; Quit if pointer moved out of main menu window (setf selected-item (when (eq kind :ancestor) :none)) ;; Otherwise, unhighlight the item window left (let ((position (position window items :key #'first))) (when position (menu-unhighlight-item menu position)))) t) (otherwise () ;;Ignore and discard any other event t))) ;; Erase the menu (UNMAP-WINDOW mw) ;; Return selected item string, if any (unless (eq selected-item :none) selected-item))) (defun menu-highlight-item (menu position) (let* ((box-margin (round *menu-item-margin* 2)) (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) box-margin)) (top (- (* (+ *menu-item-margin* (menu-item-height menu)) (1+ position)) box-margin)) (width (+ (menu-item-width menu) box-margin box-margin)) (height (+ (menu-item-height menu) box-margin box-margin))) ;; Draw a box in menu window around the given item. (DRAW-RECTANGLE (menu-window menu) (menu-gcontext menu) left top width height))) (defun menu-unhighlight-item (menu position) ;; Draw a box in the menu background color (let ((gcontext (menu-gcontext menu))) (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext)) (menu-highlight-item menu position)))) (defun menu-present (menu x y) ;; Make sure menu geometry is up-to-date (menu-recompute-geometry menu) ;; Try to center first item at the given location, but ;; make sure menu is completely visible in its parent (let ((menu-window (menu-window menu))) (multiple-value-bind (tree parent) (QUERY-TREE menu-window) (declare (ignore tree)) (WITH-STATE (parent) (let* ((parent-width (DRAWABLE-WIDTH parent)) (parent-height (DRAWABLE-HEIGHT parent)) (menu-height (+ *menu-item-margin* (* (1+ (length (menu-item-alist menu))) (+ (menu-item-height menu) *menu-item-margin*)))) (menu-x (max 0 (min (- parent-width (menu-width menu)) (- x (round (menu-width menu) 2))))) (menu-y (max 0 (min (- parent-height menu-height) (- y (round (menu-item-height menu) 2/3) *menu-item-margin*))))) (WITH-STATE (menu-window) (setf (DRAWABLE-X menu-window) menu-x (DRAWABLE-Y menu-window) menu-y))))) ;; Make menu visible (MAP-WINDOW menu-window))) (defun just-say-lisp (&optional (font-name "fixed")) (let* ((display (open-default-display)) (screen (first (DISPLAY-ROOTS display))) (fg-color (SCREEN-BLACK-PIXEL screen)) (bg-color (SCREEN-WHITE-PIXEL screen)) (nice-font (OPEN-FONT display font-name)) (a-menu (create-menu (screen-root screen) ;the menu's parent fg-color bg-color nice-font))) (setf (menu-title a-menu) "Please pick your favorite language:") (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") ;; Bedevil the user until he picks a nice programming language (unwind-protect (do (choice) ((and (setf choice (menu-choose a-menu 100 100)) (string-equal "Lisp" choice)))) (CLOSE-DISPLAY display)))) (defun pop-up (host strings &key (title "Pick one:") (font "fixed")) (let* ((display (OPEN-DISPLAY host)) (screen (first (DISPLAY-ROOTS display))) (fg-color (SCREEN-BLACK-PIXEL screen)) (bg-color (SCREEN-WHITE-PIXEL screen)) (font (OPEN-FONT display font)) (parent-width 400) (parent-height 400) (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) :override-redirect :on :x 100 :y 100 :width parent-width :height parent-height :background bg-color :event-mask (MAKE-EVENT-MASK :button-press :exposure))) (a-menu (create-menu parent fg-color bg-color font)) (prompt "Press a button...") (prompt-gc (CREATE-GCONTEXT :drawable parent :foreground fg-color :background bg-color :font font)) (prompt-y (FONT-ASCENT font)) (ack-y (- parent-height (FONT-DESCENT font)))) (setf (menu-title a-menu) title) (apply #'menu-set-item-list a-menu strings) ;; Present main window (MAP-WINDOW parent) (flet ((display-centered-text (window string gcontext height width) (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) (declare (ignore a d l r)) (let ((box-height (+ fa fd))) ;; Clear previous text (CLEAR-AREA window :x 0 :y (- height fa) :width width :height box-height) ;; Draw new text (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) (unwind-protect (loop (EVENT-CASE (display :force-output-p t) (:exposure (count) ;; Display prompt (when (zerop count) (display-centered-text parent prompt prompt-gc prompt-y parent-width)) t) (:button-press (x y) ;; Pop up the menu (let ((choice (menu-choose a-menu x y))) (if choice (display-centered-text parent (format nil "You have selected ~a." choice) prompt-gc ack-y parent-width) (display-centered-text parent "No selection...try again." prompt-gc ack-y parent-width))) t) (otherwise () ;;Ignore and discard any other event t))) (CLOSE-DISPLAY display))))) cmucl-21a/src/clx/demo/zoid.lisp000066400000000000000000000040351260377556400167220ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX interface for Trapezoid Extension. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (export '(draw-filled-trapezoids gcontext-trapezoid-alignment ;; Setf'able )) (define-extension "ZoidExtension") (defun draw-filled-trapezoids (drawable gcontext points) ;; Draw trapezoids on drawable using gcontext. ;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned ;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned ;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment] ;; Alignment is set with the ALIGNMENT keyword argument, which may be ;; :X, :Y, or NIL (use previous alignment) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points)) (let* ((display (drawable-display drawable)) (opcode (extension-opcode display "ZoidExtension"))) (with-buffer-request (display opcode :gc-force gcontext) ((data card8) 1) ;; X_PolyFillZoid (drawable drawable) (gcontext gcontext) ((sequence :format int16) points)))) (define-gcontext-accessor trapezoid-alignment :default :x :set-function set-trapezoid-alignment) (defun set-trapezoid-alignment (gcontext alignment) (declare (type (member :x :y) alignment)) (let* ((display (gcontext-display gcontext)) (opcode (extension-opcode display "ZoidExtension"))) (with-buffer-request (display opcode) ((data card8) 2) ;; X_SetZoidAlignment (gcontext gcontext) ((member8 %error :x :y) alignment)))) cmucl-21a/src/clx/dep-allegro.lisp000066400000000000000000002300771260377556400172330ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: dep-allegro.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) (proclaim '(declaration array-register)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) #-(or clx-overlapping-arrays (not clx-little-endian)) (progn (defconstant +word-0+ 0) (defconstant +word-1+ 1) (defconstant +long-0+ 0) (defconstant +long-1+ 1) (defconstant +long-2+ 2) (defconstant +long-3+ 3)) #-(or clx-overlapping-arrays clx-little-endian) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) #-Genera (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays (not Genera)) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (setf (aref a i) v)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (setf (aref a i) (int16->card16 v)) v) (defun aref-card32 (a i) (aref a i)) (defun aset-card32 (v a i) (setf (aref a i) v)) (defun aref-int32 (a i) (card32->int32 (aref a i))) (defun aset-int32 (v a i) (setf (aref a i) (int32->card32 v)) v) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (setf (aref a i) v)) ) #+excl (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i :unsigned-long) v)) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) #+(or cmu sbcl) (progn ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI ;;; is irrational, there can't be a precise rational representation. In ;;; particular, the different float approximations will always be /=. This ;;; causes problems with type checking, because people might compute an ;;; argument in any precision. What we do is discard all the excess precision ;;; in the value, and see if the protocol encoding falls in the desired range ;;; (64'ths of a degree.) ;;; (deftype angle () '(satisfies anglep)) (defun anglep (x) (and (typep x 'real) (<= (* -360 64) (radians->int16 x) (* 360 64)))) ) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `(#-lispm ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; One the lispm, #\Newline is #\Return, but we'd really like ;; #\Newline to translate to ascii code 10, so we swap the ;; Ascii codes for #\Return and #\Linefeed. We also provide ;; mappings from the counterparts of these control characters ;; so that the character mapping from the lisp machine ;; character set to ascii is invertible. #+lispm ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) #-Genera (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) #-Minima (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) #-Minima (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. #+excl (defun make-process-lock (name) (mp:make-process-lock :name name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect ;;; against re-entering request functions. This can happen if an interrupt ;;; occurs and the handler attempts to use X over the same display connection. ;;; This can happen if the GC hooks are used to notify the user over the same ;;; display connection. We inhibit GC notifications since display of them ;;; could cause recursive entry into CLX. ;;; ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. ;;; #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect (block .hl-doit. (when (sys:scheduler-running-p) ; fast test for scheduler running (setq .hl-lock. ,locator .hl-curproc. mp::*current-process*) (when (and .hl-curproc. ; nil if in process-wait fun (not (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))) ;; Then we need to grab the lock. ,(if timeout `(if (not (mp::process-lock .hl-lock. .hl-curproc. ,whostate ,timeout)) (return-from .hl-doit. nil)) `(mp::process-lock .hl-lock. .hl-curproc. ,@(when whostate `(,whostate)))) ;; There is an apparent race condition here. However, there is ;; no actual race condition -- our implementation of mp:process- ;; lock guarantees that the lock will still be held when it ;; returns, and no interrupt can happen between that and the ;; execution of the next form. -- jdi 2/27/91 (setq .hl-obtained-lock. t))) ,@body) (if (and .hl-obtained-lock. ;; Note -- next form added to allow error handler inside ;; body to unlock the lock prematurely if it knows that ;; the current process cannot possibly continue but will ;; throw out (or is it throw up?). (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) (mp::process-unlock .hl-lock. .hl-curproc.))))) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. #+excl (defmacro without-aborts (&body body) `(without-interrupts ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. #+excl (defun process-block (whostate predicate &rest predicate-args) (if (sys:scheduler-running-p) (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler.")))) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) (error "~s is not a process" curproc)) (unless (mp::process-p process) (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) (mp::process-allow-schedule process))))) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. #+excl (defun current-process () (and (sys:scheduler-running-p) mp::*current-process*)) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. #-sbcl (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- #-Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) #-Genera (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server ;; ;; Note that since we don't use the CL i/o facilities to do i/o, the display ;; input and output "stream" is really a file descriptor (fixnum). ;; #+excl (defun open-x-stream (host display protocol) (declare (ignore protocol)) ;; assume TCP (let ((stream (socket:make-socket :remote-host (string host) :remote-port (+ *x-tcp-port* display) :format :binary))) (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) ;;; BUFFER-READ-DEFAULT - read data from the X stream ;; ;; Rewritten 10/89 to not use foreign function interface to do I/O. ;; #+excl (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) (fd (display-input-stream display))) (declare (type array-index howmany)) (or (cond ((fd-char-avail-p fd) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (fd-read-bytes fd vector start howmany)))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. ;;; BUFFER-WRITE-DEFAULT - write data to the X stream #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (unless (null stream) (write-sequence vector stream :start start :end end))) ) ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. ;;; buffer-force-output-default - force output to the X stream #+excl (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream #+excl (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation ;; ;; This is used so an 'eq' test may be used to find out whether or not we can ;; safely throw this process out of the CLX read loop. ;; #+excl (defparameter *read-whostate* "waiting for input from X server") ;; ;; Note that this function returns nil on error if the scheduler is running, ;; t on error if not. This is ok since buffer-read will detect the error. ;; #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (when (streamp fd) (cond ((fd-char-avail-p fd) nil) ;; Otherwise no bytes were available on the socket ((and timeout (= timeout 0)) ;; If there aren't enough and timeout == 0, timeout. :timeout) ;; If the scheduler is running let it do timeouts. ((sys:scheduler-running-p) (if (not (mp:wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p :timeout timeout)) (return-from buffer-input-wait-default :timeout)) ) ;; Otherwise we have to handle timeouts by hand, and call select() ;; to block until input is available. Note we don't really handle ;; the interaction of interrupts and (numberp timeout) here. XX (t #+mswindows (error "scheduler must be running to use CLX on MS Windows") #-mswindows (let ((res 0)) (declare (fixnum res)) (with-interrupt-checking-on (loop (setq res (fd-wait-for-input fd (if (null timeout) 0 (truncate timeout)))) (cond ((plusp res) ; success (return nil)) ((eq res 0) ; timeout (return :timeout)) ((eq res -1) ; error (return t)) ;; Otherwise we got an interrupt -- go around again. ))))))))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. #+excl #+(and excl clx-use-allegro-streams) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) #+(and excl (not clx-use-allegro-streams)) (defun buffer-listen-default (display) (declare (type display display)) (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) t (fd-char-avail-p fd)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; #-lispm (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) #+excl (defun buffer-replace (target-sequence source-sequence target-start target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) (type array-index target-start target-end source-start) (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) (> target-start source-start)) then (let ((nelts (min (- target-end target-start) (- source-end source-start)))) (do ((target-index (+ target-start nelts -1) (1- target-index)) (source-index (+ source-start nelts -1) (1- source-index))) ((= target-index (1- target-start)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index))) ((or (= target-index target-end) (= source-index source-end)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ #+(or Genera Minima CMU sbcl) nil #-(or Genera Minima CMU sbcl) t) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) #+(or cmu sbcl) `(typep ,object ,type) #-(or cmu sbcl) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type)) `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) #+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;;; X-ERROR for CMU Common Lisp ;;; ;;; We detect a couple condition types for which we disable event handling in ;;; our system. This prevents going into the debugger or returning to a ;;; command prompt with CLX repeatedly seeing the same condition. This occurs ;;; because CMU Common Lisp provides for all events (that is, X, input on file ;;; descriptors, Mach messages, etc.) to come through one routine anyone can ;;; use to wait for input. ;;; #+(and CMU (not mp)) (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) (warn "Disabled event handling on ~S." disp) (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) #+(and excl (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (define-condition x-error (error) ()) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- #+(and allegro-version>= (version>= 5 0)) (eval-when (compile eval load) #+(version>= 6 0) (progn (require :sock) #-(version>= 7 0) (require :gray-compat)) #-(version>= 6 0) (require :sock)) #+(and allegro-version>= (version>= 5 0)) (defun host-address (host &optional (family :internet)) (ecase family (:internet (cons :internet (multiple-value-list (socket::ipaddr-to-dotted (socket::lookup-hostname host) :values t)))))) #+(and allegro-version>= (not (version>= 5 0))) (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect (progn (setf hostent (ipc::gethostbyname (string host))) (when (zerop hostent) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (ipc::hostent-addrtype hostent) 2) (no-address-error)) (assert (= (ipc::hostent-length hostent) 4)) (let ((addr (ipc::hostent-addr hostent))) (when (or (member comp::.target. '(:hp :sgi4d :sony :dec3100) :test #'eq) (probe-file "/lib/ld.so")) ;; BSD 4.3 based systems require an extra indirection (setq addr (si:memref-int addr 0 0 :unsigned-long))) (list :internet (si:memref-int addr 0 0 :unsigned-byte) (si:memref-int addr 1 0 :unsigned-byte) (si:memref-int addr 2 0 :unsigned-byte) (si:memref-int addr 3 0 :unsigned-byte)))))) (ff:free-cstruct hostent))))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () #+(or lispm Minima) t #-(or lispm Minima) nil) #-(or Genera Minima) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) #+excl (sys:getenv name) ) (defun get-host-name () "Return the same hostname as gethostname(3) would" ;; resources-pathname was using short-site-name for this purpose #+excl (short-site-name) ) (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think #+unix (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) ;;----------------------------------------------------------------------------- ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera CMU sbcl) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) (let ((*package* (find-package :user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-pretty* nil) (*print-radix* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-suppress* nil) ) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (clx-values t) (special left-meta-keysym right-meta-keysym left-super-keysym right-super-keysym left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () #-(or Genera Minima) '(unsigned-byte 32) #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR #+excl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (#-Genera ldb #+Genera sys:%logldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (#-Genera ldb #+Genera sys:%logldb (byte 8 ,position) #-Genera (the (unsigned-byte ,integer-size) ,integer) #+Genera ,integer ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) #+(or Genera lcl3.0 excl) (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant *image-bit-ordering-table* '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) #+(or Genera lcl3.0 excl) (defun compute-image-byte-and-bit-ordering () (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) (declare (optimize (speed 3) (safety 0) (space 0))) (declare (type (simple-array bit (* *)) a) (type fixnum i n)) (with-underlying-simple-vector (v (unsigned-byte 8) a) (prog2 (setf (aref v i) n) (dotimes (i 32) (unless (zerop (aref a 0 i)) (return i))) (setf (aref v i) 0))))) (list (bitpos a i #b10000000) (bitpos a i #b00000001))) ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering (second (assoc ordering *image-bit-ordering-table* :test #'equal)))) (unless byte-and-bit-ordering (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) (multiple-value-setq (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (compute-image-byte-and-bit-ordering)) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FIXME: though we have some #+sbcl -conditionalized routines in ;;; here, they would appear not to work, and so are commented out in ;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate ;;; whether the unoptimized routines are often used, and also whether ;;; speeding them up while maintaining correctness is possible. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the fixnum (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (the fixnum (- (the fixnum (- width left-bits)) right-bits))) (middle-bytes (index-floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits middle-bytes) (fixnum middle-bits)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-bits) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (array-row-major-index array y (index+ left-bits middle-bits)))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref vector (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) 2))) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-nibbles) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y 0) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref vector x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) t) ;;; COPY-BIT-RECT -- Internal ;;; ;;; This is the classic BITBLT operation, copying a rectangular subarray ;;; from one array to another (but source and destination must not overlap.) ;;; Widths are specified in bits. Neither array can have a non-zero ;;; displacement. We allow extra random bit-offset to be thrown into the X. ;;; #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod x-bits 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod x-bits +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (dst card8 pixarray) (funcall (symbol-function image-swap-function) bbuf dst (index+ boffset (index* y padded-bytes-per-line) (index-floor x-bits 8)) 0 (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line (index-floor pixarray-padded-bits-per-line 8) height image-swap-lsb-first-p))) t)))) (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-read-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-read-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-read-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (array-row-major-index array y (index+ start-x middle-bits)))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref vector (index+ x 0)) (if (index> right-bits 1) (aref vector (index+ x 1)) 0) (if (index> right-bits 2) (aref vector (index+ x 2)) 0) (if (index> right-bits 3) (aref vector (index+ x 3)) 0) (if (index> right-bits 4) (aref vector (index+ x 4)) 0) (if (index> right-bits 5) (aref vector (index+ x 5)) 0) (if (index> right-bits 6) (aref vector (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)) (aref vector (index+ x 2)) (aref vector (index+ x 3)) (aref vector (index+ x 4)) (aref vector (index+ x 5)) (aref vector (index+ x 6)) (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y x) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref vector x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p* unit byte-lsb-first-p bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (src card8 pixarray) (funcall (symbol-function image-swap-function) src bbuf (index-floor pixarray-start-bit-offset 8) boffset (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) padded-bytes-per-line height image-swap-lsb-first-p)) t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-write-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-write-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-write-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-write-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (when function (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1)) (pixarray-padded-bits-per-line (* pixarray-padded-pixels-per-line bits-per-pixel)) (copy-padded-pixels-per-line #+Genera (sys:array-row-span copy) #-Genera (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) t) #+(or CMU) (when (index= (pixarray-element-size pixarray) (pixarray-element-size copy) bits-per-pixel) (copy-bit-rect pixarray pixarray-padded-bits-per-line x y copy copy-padded-bits-per-line 0 0 height (index* width bits-per-pixel)) t)) #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (copy-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index copy 1 0) (array-row-major-index copy 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line copy-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod copy-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (with-underlying-simple-vector (src card8 pixarray) (with-underlying-simple-vector (dst card8 copy) (image-noswap src dst (index-floor pixarray-start-bit-offset 8) 0 (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) (index-floor copy-padded-bits-per-line 8) height nil))) t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) `(let ((pixarray pixarray) (copy copy)) (declare (type ,type pixarray copy)) #.(declare-buffun) (with-underlying-simple-vector (src ,element-type pixarray) (with-underlying-simple-vector (dst ,element-type copy) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-idx (array-row-major-index copy dst-y 0) (index1+ dst-idx)) (dst-end (index+ dst-idx width)) (src-idx (array-row-major-index pixarray src-y x) (index1+ src-idx))) ((index>= dst-idx dst-end)) (declare (type array-index dst-idx src-idx dst-end)) (setf (aref dst dst-idx) (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))) t))) cmucl-21a/src/clx/dep-openmcl.lisp000066400000000000000000001112711260377556400172350ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: dep-openmcl.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") (in-package :xlib) (proclaim '(declaration array-register)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) ) (progn (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `( ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; The rest of the common lisp charater set with ;; the normal ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. (defun make-process-lock (name) (ccl:make-lock name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore timeout display)) `(ccl:with-lock-grabbed (,locator ,whostate) ,@body)) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. (defmacro without-aborts (&body body) `(ccl:without-interrupts ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. (defun process-block (whostate predicate &rest predicate-args) (declare (dynamic-extern predicate-args)) (apply #'ccl:process-wait whostate predicate predicate-args)) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) (defun process-wakeup (process) (declare (ignore process)) nil) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. (defun current-process () ccl::*current-process*) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. (defmacro without-interrupts (&body body) `(ccl:without-interrupts ,@body)) ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. (defmacro conditional-store (place old-value new-value) `(ccl::conditional-store ,place ,old-value ,new-value)) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server (defun open-x-stream (host display protocol) (declare (ignore protocol)) (let ((local-socket-path (unix-socket-path-from-host host display))) (if local-socket-path (ccl::make-socket :connect :active :address-family :file :remote-filename local-socket-path) (ccl::make-socket :connect :active :remote-host host :remote-port (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (progn (ccl:stream-read-ivector stream vector start (- end start)) nil)))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (ccl:stream-write-ivector stream vector start (- end start))) nil)) ;;; buffer-force-output-default - force output to the X stream (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) (t (let* ((fd (ccl::stream-device stream :input)) (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*))))) (if (ccl::process-input-wait fd ticks) nil :timeout)))))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ nil) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) (define-condition x-error (error) ()) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) (let* ((addr (ccl::host-as-inet-host host))) (cons :internet (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () nil) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) (ccl::getenv name)) (defun get-host-name () "Return the same hostname as gethostname(3) would" (machine-instance)) (defun homedir-file-pathname (name) (merge-pathnames (user-homedir-pathname) (pathname name))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (ignore display state) (clx-values t)) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () '(unsigned-byte 32)) (deftype pixarray-1 () '(array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(let* ((,variable (ccl::array-data-and-offset ,pixarray))) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (ldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) `(the (unsigned-byte ,(* (length bytes) 8)) ,it))) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (ldb (byte 8 ,position) (the (unsigned-byte ,integer-size) ,integer)))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(dpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)) nil) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (ignore bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsp-first-p)) nil) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (ignore pixarray copy x y width height bits-per-pixel)) nil) cmucl-21a/src/clx/depdefs.lisp000066400000000000000000000563311260377556400164510ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: depdefs.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;;;------------------------------------------------------------------------- ;;; Declarations ;;;------------------------------------------------------------------------- ;;; fix a bug in kcl's RATIONAL... ;;; redefine both the function and the type. #+(or kcl ibcl) (progn (defun rational (x) (if (rationalp x) x (lisp:rational x))) (deftype rational (&optional l u) `(lisp:rational ,l ,u))) ;;; DECLAIM #-clx-ansi-common-lisp (defmacro declaim (&rest decl-specs) (if (cdr decl-specs) `(progn ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec)) decl-specs)) `(proclaim ',(car decl-specs)))) ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function. #-Genera (declaim (declaration clx-values)) #+Genera (setf (get 'clx-values 'si:declaration-alias) 'scl:values) ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides ;;; the documentation that might get generated by the real arglist of the ;;; function. #-(or lispm lcl3.0) (declaim (declaration arglist)) ;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has ;;; dynamic extent and therefore can be kept on the stack and not copied to ;;; the heap, even though the value is passed out of the function. #-(or clx-ansi-common-lisp lcl3.0) (declaim (declaration dynamic-extent)) ;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used. #-clx-ansi-common-lisp (declaim (declaration ignorable)) ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to ;;; indent calls to the function or macro containing the declaration. #-genera (declaim (declaration indentation)) ;;;------------------------------------------------------------------------- ;;; Declaration macros ;;;------------------------------------------------------------------------- ;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local ;;; and then does a type declaration and array register declaration (defmacro with-vector ((var type) &body body) `(let ((,var ,var)) (declare (type ,type ,var)) ,@body)) ;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for ;;; Meta-. #+lispm (defmacro within-definition ((name type) &body body) `(zl:local-declare ((sys:function-parent ,name ,type)) (sys:record-source-file-name ',name ',type) ,@body)) #-lispm (defmacro within-definition ((name type) &body body) (declare (ignore name type)) `(progn ,@body)) ;;;------------------------------------------------------------------------- ;;; CLX can maintain a mapping from X server ID's to local data types. If ;;; one takes the view that CLX objects will be instance variables of ;;; objects at the next higher level, then PROCESS-EVENT will typically map ;;; from resource-id to higher-level object. In that case, the lower-level ;;; CLX mapping will almost never be used (except in rare cases like ;;; query-tree), and only serve to consume space (which is difficult to ;;; GC), in which case always-consing versions of the make-s will ;;; be better. Even when maps are maintained, it isn't clear they are ;;; useful for much beyond xatoms and windows (since almost nothing else ;;; ever comes back in events). ;;;-------------------------------------------------------------------------- (defconstant +clx-cached-types+ '(drawable window pixmap ;; gcontext cursor colormap font)) (defmacro resource-id-map-test () #+excl '#'equal #-excl '#'eql) ; (eq fixnum fixnum) is not guaranteed. (defmacro atom-cache-map-test () #+excl '#'equal #-excl '#'eq) (defmacro keysym->character-map-test () #+excl '#'equal #-excl '#'eql) ;;; You must define this to match the real byte order. It is used by ;;; overlapping array and image code. #+(or lispm vax little-endian Minima) (eval-when (eval compile load) (pushnew :clx-little-endian *features*)) #+lcl3.0 (eval-when (compile eval load) (ecase lucid::machine-endian (:big nil) (:little (pushnew :clx-little-endian *features*)))) #+cmu (eval-when (compile eval load) (ecase #.(c:backend-byte-order c:*backend*) (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) ;; FIXME: Ideally, we shouldn't end up with the internal ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists. ;; This probably wants to be split up into :compile-toplevel ;; :execute and :load-toplevel clauses, so that loading the compiled ;; code doesn't push the feature. (ecase sb-c:*backend-byte-order* (:big-endian) (:little-endian (pushnew :clx-little-endian *features*)))) ;;; Steele's Common-Lisp states: "It is an error if the array specified ;;; as the :displaced-to argument does not have the same :element-type ;;; as the array being created" If this is the case on your lisp, then ;;; leave the overlapping-arrays feature turned off. Lisp machines ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays ;;; with different element types to overlap. CLX will take advantage of ;;; this to do fast array packing/unpacking when the overlapping-arrays ;;; feature is enabled. #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (unless system::*big-endian* (pushnew :clx-little-endian *features*))) #+(and clx-little-endian lispm) (eval-when (eval compile load) (pushnew :clx-overlapping-arrays *features*)) #+(and clx-overlapping-arrays genera) (progn (deftype overlap16 () '(unsigned-byte 16)) (deftype overlap32 () '(signed-byte 32)) ) #+(and clx-overlapping-arrays (or explorer lambda cadr)) (progn (deftype overlap16 () '(unsigned-byte 16)) (deftype overlap32 () '(unsigned-byte 32)) ) (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*))) #+clx-overlapping-arrays (progn (deftype buffer-words () `(vector overlap16)) (deftype buffer-longs () `(vector overlap32)) ) ;;; This defines a type which is a subtype of the integers. ;;; This type is used to describe all variables that can be array indices. ;;; It is here because it is used below. ;;; This is inclusive because start/end can be 1 past the end. (deftype array-index () `(integer 0 ,array-dimension-limit)) ;; this is the best place to define these? #-Genera (progn (defun make-index-typed (form) (if (constantp form) form `(the array-index ,form))) (defun make-index-op (operator args) `(the array-index (values ,(case (length args) (0 `(,operator)) (1 `(,operator ,(make-index-typed (first args)))) (2 `(,operator ,(make-index-typed (first args)) ,(make-index-typed (second args)))) (otherwise `(,operator ,(make-index-op operator (subseq args 0 (1- (length args)))) ,(make-index-typed (first (last args))))))))) (defmacro index+ (&rest numbers) (make-index-op '+ numbers)) (defmacro index-logand (&rest numbers) (make-index-op 'logand numbers)) (defmacro index-logior (&rest numbers) (make-index-op 'logior numbers)) (defmacro index- (&rest numbers) (make-index-op '- numbers)) (defmacro index* (&rest numbers) (make-index-op '* numbers)) (defmacro index1+ (number) (make-index-op '1+ (list number))) (defmacro index1- (number) (make-index-op '1- (list number))) (defmacro index-incf (place &optional (delta 1)) (make-index-op 'incf (list place delta))) (defmacro index-decf (place &optional (delta 1)) (make-index-op 'decf (list place delta))) (defmacro index-min (&rest numbers) (make-index-op 'min numbers)) (defmacro index-max (&rest numbers) (make-index-op 'max numbers)) (defmacro index-floor (number divisor) (make-index-op 'floor (list number divisor))) (defmacro index-ceiling (number divisor) (make-index-op 'ceiling (list number divisor))) (defmacro index-truncate (number divisor) (make-index-op 'truncate (list number divisor))) (defmacro index-mod (number divisor) (make-index-op 'mod (list number divisor))) (defmacro index-ash (number count) (make-index-op 'ash (list number count))) (defmacro index-plusp (number) `(plusp (the array-index ,number))) (defmacro index-zerop (number) `(zerop (the array-index ,number))) (defmacro index-evenp (number) `(evenp (the array-index ,number))) (defmacro index-oddp (number) `(oddp (the array-index ,number))) (defmacro index> (&rest numbers) `(> ,@(mapcar #'make-index-typed numbers))) (defmacro index= (&rest numbers) `(= ,@(mapcar #'make-index-typed numbers))) (defmacro index< (&rest numbers) `(< ,@(mapcar #'make-index-typed numbers))) (defmacro index>= (&rest numbers) `(>= ,@(mapcar #'make-index-typed numbers))) (defmacro index<= (&rest numbers) `(<= ,@(mapcar #'make-index-typed numbers))) ) #+Genera (progn (defmacro index+ (&rest numbers) `(+ ,@numbers)) (defmacro index-logand (&rest numbers) `(logand ,@numbers)) (defmacro index-logior (&rest numbers) `(logior ,@numbers)) (defmacro index- (&rest numbers) `(- ,@numbers)) (defmacro index* (&rest numbers) `(* ,@numbers)) (defmacro index1+ (number) `(1+ ,number)) (defmacro index1- (number) `(1- ,number)) (defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta))) (defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta))) (defmacro index-min (&rest numbers) `(min ,@numbers)) (defmacro index-max (&rest numbers) `(max ,@numbers)) (defun positive-power-of-two-p (x) (when (symbolp x) (multiple-value-bind (constantp value) (lt:named-constant-p x) (when constantp (setq x value)))) (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x))))) (defmacro index-floor (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,divisor)) (t `(floor ,number ,divisor)))) (defmacro index-ceiling (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling)) `(si:%fixnum-ceiling ,number ,divisor)) (t `(ceiling ,number ,divisor)))) (defmacro index-truncate (number divisor) (cond ((eql divisor 1) number) ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,divisor)) (t `(truncate ,number ,divisor)))) (defmacro index-mod (number divisor) (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod)) `(si:%fixnum-mod ,number ,divisor)) (t `(mod ,number ,divisor)))) (defmacro index-ash (number count) (cond ((eql count 0) number) ((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor)) `(si:%fixnum-floor ,number ,(expt 2 (- count)))) ((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply)) `(si:%fixnum-multiply ,number ,(expt 2 count))) (t `(ash ,number ,count)))) (defmacro index-plusp (number) `(plusp ,number)) (defmacro index-zerop (number) `(zerop ,number)) (defmacro index-evenp (number) `(evenp ,number)) (defmacro index-oddp (number) `(oddp ,number)) (defmacro index> (&rest numbers) `(> ,@numbers)) (defmacro index= (&rest numbers) `(= ,@numbers)) (defmacro index< (&rest numbers) `(< ,@numbers)) (defmacro index>= (&rest numbers) `(>= ,@numbers)) (defmacro index<= (&rest numbers) `(<= ,@numbers)) ) ;;;; Stuff for BUFFER definition (defconstant +replysize+ 32.) ;; used in defstruct initializations to avoid compiler warnings (defvar *empty-bytes* (make-sequence 'buffer-bytes 0)) (declaim (type buffer-bytes *empty-bytes*)) #+clx-overlapping-arrays (progn (defvar *empty-words* (make-sequence 'buffer-words 0)) (declaim (type buffer-words *empty-words*)) ) #+clx-overlapping-arrays (progn (defvar *empty-longs* (make-sequence 'buffer-longs 0)) (declaim (type buffer-longs *empty-longs*)) ) (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal) (:copier nil) (:predicate nil)) (size 0 :type array-index) ;Buffer size ;; Byte (8 bit) input buffer (ibuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) input buffer #+clx-overlapping-arrays (ibuf16 *empty-words* :type buffer-words) ;; Long (32bit) input buffer #+clx-overlapping-arrays (ibuf32 *empty-longs* :type buffer-longs) (next nil #-explorer :type #-explorer (or null reply-buffer)) (data-size 0 :type array-index) ) (defconstant +buffer-text16-size+ 256) (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+))) ;; These are here because. (defparameter *xlib-package* (find-package :xlib)) (defun xintern (&rest parts) (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*)) (defparameter *keyword-package* (find-package :keyword)) (defun kintern (name) (intern (string name) *keyword-package*)) ;;; Pseudo-class mechanism. (eval-when (:compile-toplevel :load-toplevel :execute) ;; FIXME: maybe we should reevaluate this? (defvar *def-clx-class-use-defclass* #+(or Genera allegro) t #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) #+(and cmu (not pcl)) nil #-(or Genera cmu allegro) nil "Controls whether DEF-CLX-CLASS uses DEFCLASS. If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names for which DEFCLASS should be used. If it is not a list, then DEFCLASS is always used. If it is NIL, then DEFCLASS is never used, since NIL is the empty list.") ) (defmacro def-clx-class ((name &rest options) &body slots) (if (or (not (listp *def-clx-class-use-defclass*)) (member name *def-clx-class-use-defclass*)) (let ((clos-package #+clx-ansi-common-lisp (find-package :common-lisp) #-clx-ansi-common-lisp (or (find-package :clos) (find-package :pcl) (let ((lisp-pkg (find-package :lisp))) (and (find-symbol (string 'defclass) lisp-pkg) lisp-pkg)))) (constructor t) (constructor-args t) (include nil) (print-function nil) (copier t) (predicate t)) (dolist (option options) (ecase (pop option) (:constructor (setf constructor (pop option)) (setf constructor-args (if (null option) t (pop option)))) (:include (setf include (pop option))) (:print-function (setf print-function (pop option))) (:copier (setf copier (pop option))) (:predicate (setf predicate (pop option))))) (flet ((cintern (&rest symbols) (intern (apply #'concatenate 'simple-string (mapcar #'symbol-name symbols)) *package*)) (kintern (symbol) (intern (symbol-name symbol) (find-package :keyword))) (closintern (symbol) (intern (symbol-name symbol) clos-package))) (when (eq constructor t) (setf constructor (cintern 'make- name))) (when (eq copier t) (setf copier (cintern 'copy- name))) (when (eq predicate t) (setf predicate (cintern name '-p))) (when include (setf slots (append (get include 'def-clx-class) slots))) (let* ((n-slots (length slots)) (slot-names (make-list n-slots)) (slot-initforms (make-list n-slots)) (slot-types (make-list n-slots))) (dotimes (i n-slots) (let ((slot (elt slots i))) (setf (elt slot-names i) (pop slot)) (setf (elt slot-initforms i) (pop slot)) (setf (elt slot-types i) (getf slot :type t)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'def-clx-class) ',slots)) ;; From here down are the system-specific expansions: (within-definition (,name def-clx-class) (,(closintern 'defclass) ,name ,(and include `(,include)) (,@(map 'list #'(lambda (slot-name slot-initform slot-type) `(,slot-name :initform ,slot-initform :type ,slot-type :accessor ,(cintern name '- slot-name) ,@(when (and constructor (or (eq constructor-args t) (member slot-name constructor-args))) `(:initarg ,(kintern slot-name))) )) slot-names slot-initforms slot-types))) ,(when constructor (if (eq constructor-args t) `(defun ,constructor (&rest args) (apply #',(closintern 'make-instance) ',name args)) `(defun ,constructor ,constructor-args (,(closintern 'make-instance) ',name ,@(mapcan #'(lambda (slot-name) (and (member slot-name slot-names) `(,(kintern slot-name) ,slot-name))) constructor-args))))) ,(when predicate #+allegro `(progn (,(closintern 'defmethod) ,predicate (object) (declare (ignore object)) nil) (,(closintern 'defmethod) ,predicate ((object ,name)) t)) #-allegro `(defun ,predicate (object) (typep object ',name))) ,(when copier `(,(closintern 'defmethod) ,copier ((.object. ,name)) (,(closintern 'with-slots) ,slot-names .object. (,(closintern 'make-instance) ',name ,@(mapcan #'(lambda (slot-name) `(,(kintern slot-name) ,slot-name)) slot-names))))) ,(when print-function `(,(closintern 'defmethod) ,(closintern 'print-object) ((object ,name) stream) (,print-function object stream 0)))))))) `(within-definition (,name def-clx-class) (defstruct (,name ,@options) ,@slots)))) #+Genera (progn (scl:defprop def-clx-class "CLX Class" si:definition-type-name) (scl:defprop def-clx-class zwei:defselect-function-spec-finder zwei:definition-function-spec-finder)) ;; We need this here so we can define DISPLAY for CLX. ;; ;; This structure is :INCLUDEd in the DISPLAY structure. ;; Overlapping (displaced) arrays are provided for byte ;; half-word and word access on both input and output. ;; (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil)) ;; Lock for multi-processing systems (lock (make-process-lock "CLX Buffer Lock")) #-excl (output-stream nil :type (or null stream)) #+excl (output-stream -1 :type fixnum) ;; Buffer size (size 0 :type array-index) (request-number 0 :type (unsigned-byte 16)) ;; Byte position of start of last request ;; used for appending requests and error recovery (last-request nil :type (or null array-index)) ;; Byte position of start of last flushed request (last-flushed-request nil :type (or null array-index)) ;; Current byte offset (boffset 0 :type array-index) ;; Byte (8 bit) output buffer (obuf8 *empty-bytes* :type buffer-bytes) ;; Word (16bit) output buffer #+clx-overlapping-arrays (obuf16 *empty-words* :type buffer-words) ;; Long (32bit) output buffer #+clx-overlapping-arrays (obuf32 *empty-longs* :type buffer-longs) ;; Holding buffer for 16-bit text (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0)) ;; Probably EQ to Output-Stream #-excl (input-stream nil :type (or null stream)) #+excl (input-stream -1 :type fixnum) ;; T when the host connection has gotten errors (dead nil :type (or null (not null))) ;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited. (flush-inhibit nil :type (or null (not null))) ;; Change these functions when using shared memory buffers to the server ;; Function to call when writing the buffer (write-function 'buffer-write-default) ;; Function to call when flushing the buffer (force-output-function 'buffer-force-output-default) ;; Function to call when closing a connection (close-function 'buffer-close-default) ;; Function to call when reading the buffer (input-function 'buffer-read-default) ;; Function to call to wait for data to be input (input-wait-function 'buffer-input-wait-default) ;; Function to call to listen for input data (listen-function 'buffer-listen-default) #+Genera (debug-io nil :type (or null stream)) ) ;;----------------------------------------------------------------------------- ;; Printing routines. ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera) (defun print-unreadable-object-function (object stream type identity function) (declare #+lispm (sys:downward-funarg function)) (princ "#<" stream) (when type (let ((type (type-of object)) (pcl-package (find-package :pcl))) ;; Handle pcl type-of lossage (when (and pcl-package (symbolp type) (eq (symbol-package type) pcl-package) (string-equal (symbol-name type) "STD-INSTANCE")) (setq type (funcall (intern (symbol-name 'class-name) pcl-package) (funcall (intern (symbol-name 'class-of) pcl-package) object)))) (prin1 type stream))) (when (and type function) (princ " " stream)) (when function (funcall function)) (when (and (or type function) identity) (princ " " stream)) (when identity (princ "???" stream)) (princ ">" stream) nil) #-(or clx-ansi-common-lisp Genera) (defmacro print-unreadable-object ((object stream &key type identity) &body body) (if body `(flet ((.print-unreadable-object-body. () ,@body)) (print-unreadable-object-function ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- (defconstant +image-bit-lsb-first-p+ #+clx-little-endian t #-clx-little-endian nil) (defconstant +image-byte-lsb-first-p+ #+clx-little-endian t #-clx-little-endian nil) (defconstant +image-unit+ 32) (defconstant +image-pad+ 32) ;;----------------------------------------------------------------------------- ;; Foreign Functions ;;----------------------------------------------------------------------------- #+(and lucid apollo (not lcl3.0)) (lucid::define-foreign-function '(connect-to-server "connect_to_server") '((:val host :string) (:val display :integer32)) :integer32) #+(and lucid (not apollo) (not lcl3.0)) (lucid::define-c-function connect-to-server (host display) :result-type :integer) #+lcl3.0 (lucid::def-foreign-function (connect-to-server (:language :c) (:return-type :signed-32bit)) (host :simple-string) (display :signed-32bit)) ;;----------------------------------------------------------------------------- ;; Finding the server socket ;;----------------------------------------------------------------------------- ;; These are here because dep-openmcl.lisp and dependent.lisp both need them (defconstant +X-unix-socket-path+ "/tmp/.X11-unix/X" "The location of the X socket") (defun unix-socket-path-from-host (host display) "Return the name of the unix domain socket for host and display, or nil if a network socket should be opened." (cond ((or (string= host "") (string= host "unix")) (format nil "~A~D" +X-unix-socket-path+ display)) #+darwin ((and (> (length host) 10) (string= host "tmp/launch" :end1 10)) (format nil "/~A:~D" host display)) (t nil))) cmucl-21a/src/clx/dependent.lisp000066400000000000000000004217001260377556400170010ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*- ;; This file contains some of the system dependent code for CLX ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: dependent.lisp,v 1.18 2009/06/17 18:28:11 rtoy Rel $") (in-package :xlib) (proclaim '(declaration array-register)) #+cmu (setf (getf ext:*herald-items* :xlib) `(" CLX X Library " ,*version*)) ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) #+explorer (zwei:define-indentation event-case (1 1)) ;;; Number of seconds to wait for a reply to a server request (defparameter *reply-timeout* nil) #-(or clx-overlapping-arrays (not clx-little-endian)) (progn (defconstant +word-0+ 0) (defconstant +word-1+ 1) (defconstant +long-0+ 0) (defconstant +long-1+ 1) (defconstant +long-2+ 2) (defconstant +long-3+ 3)) #-(or clx-overlapping-arrays clx-little-endian) (progn (defconstant +word-0+ 1) (defconstant +word-1+ 0) (defconstant +long-0+ 3) (defconstant +long-1+ 2) (defconstant +long-2+ 1) (defconstant +long-3+ 0)) ;;; Set some compiler-options for often used code (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3 "Speed compiler option for buffer code.") (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0 "Safety compiler option for buffer code.") (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1 "Debug compiler option for buffer code>") (defun declare-bufmac () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+)))) ;; It's my impression that in lucid there's some way to make a ;; declaration called fast-entry or something that causes a function ;; to not do some checking on args. Sadly, we have no lucid manuals ;; here. If such a declaration is available, it would be a good ;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+ ;; is 0. (defun declare-buffun () `(declare (optimize (speed ,+buffer-speed+) (safety ,+buffer-safety+) (debug ,+buffer-debug+))))) (declaim (inline card8->int8 int8->card8 card16->int16 int16->card16 card32->int32 int32->card32)) #-Genera (progn (defun card8->int8 (x) (declare (type card8 x)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (if (logbitp 7 x) (the int8 (- x #x100)) x))) (defun int8->card8 (x) (declare (type int8 x)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (ldb (byte 8 0) x))) (defun card16->int16 (x) (declare (type card16 x)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (if (logbitp 15 x) (the int16 (- x #x10000)) x))) (defun int16->card16 (x) (declare (type int16 x)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (ldb (byte 16 0) x))) (defun card32->int32 (x) (declare (type card32 x)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (if (logbitp 31 x) (the int32 (- x #x100000000)) x))) (defun int32->card32 (x) (declare (type int32 x)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (ldb (byte 32 0) x))) ) #+Genera (progn (defun card8->int8 (x) (declare lt:(side-effects simple reducible)) (if (logbitp 7 x) (- x #x100) x)) (defun int8->card8 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 8 0) x)) (defun card16->int16 (x) (declare lt:(side-effects simple reducible)) (if (logbitp 15 x) (- x #x10000) x)) (defun int16->card16 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 16 0) x)) (defun card32->int32 (x) (declare lt:(side-effects simple reducible)) (sys:%logldb (byte 32 0) x)) (defun int32->card32 (x) (declare lt:(side-effects simple reducible)) (ldb (byte 32 0) x)) ) (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8)) #-(or Genera lcl3.0 excl) (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (aref a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a i) (int8->card8 v))) ) #+Genera (progn (defun aref-card8 (a i) (aref a i)) (defun aset-card8 (v a i) (zl:aset v a i)) (defun aref-int8 (a i) (card8->int8 (aref a i))) (defun aset-int8 (v a i) (zl:aset (int8->card8 v) a i)) ) #+(or excl lcl3.0 clx-overlapping-arrays) (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29)) #+(and clx-overlapping-arrays Genera) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (zl:aset v a i)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (zl:aset (int16->card16 v) a i) v) (defun aref-card32 (a i) (int32->card32 (aref a i))) (defun aset-card32 (v a i) (zl:aset (card32->int32 v) a i)) (defun aref-int32 (a i) (aref a i)) (defun aset-int32 (v a i) (zl:aset v a i)) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (zl:aset v a i)) ) #+(and clx-overlapping-arrays (not Genera)) (progn (defun aref-card16 (a i) (aref a i)) (defun aset-card16 (v a i) (setf (aref a i) v)) (defun aref-int16 (a i) (card16->int16 (aref a i))) (defun aset-int16 (v a i) (setf (aref a i) (int16->card16 v)) v) (defun aref-card32 (a i) (aref a i)) (defun aset-card32 (v a i) (setf (aref a i) v)) (defun aref-int32 (a i) (card32->int32 (aref a i))) (defun aset-int32 (v a i) (setf (aref a i) (int32->card32 v)) v) (defun aref-card29 (a i) (aref a i)) (defun aset-card29 (v a i) (setf (aref a i) v)) ) #+excl (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card8)) #.(declare-buffun) (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-byte))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-byte) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int8)) #.(declare-buffun) (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-byte))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-byte) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-word))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-word) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-word))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-word) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-long))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :signed-long) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i :unsigned-long) v)) ) #+lcl3.0 (progn (defun aref-card8 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card8)) #.(declare-buffun) (the card8 (lucid::%svref-8bit a i))) (defun aset-card8 (v a i) (declare (type card8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-8bit a i) v)) (defun aref-int8 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int8)) #.(declare-buffun) (the int8 (lucid::%svref-signed-8bit a i))) (defun aset-int8 (v a i) (declare (type int8 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-8bit a i) v)) (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card16)) #.(declare-buffun) (the card16 (lucid::%svref-16bit a (index-ash i -1)))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-16bit a (index-ash i -1)) v)) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int16)) #.(declare-buffun) (the int16 (lucid::%svref-signed-16bit a (index-ash i -1)))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v)) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card32)) #.(declare-buffun) (the card32 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values int32)) #.(declare-buffun) (the int32 (lucid::%svref-signed-32bit a (index-ash i -2)))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v)) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i) (clx-values card29)) #.(declare-buffun) (the card29 (lucid::%svref-32bit a (index-ash i -2)))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (lucid::%svref-32bit a (index-ash i -2)) v)) ) #-(or excl lcl3.0 clx-overlapping-arrays) (progn (defun aref-card16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card16)) #.(declare-buffun) (the card16 (logior (the card16 (ash (the card8 (aref a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-card16 (v a i) (declare (type card16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int16 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (logior (the int16 (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8)) (the card8 (aref a (index+ i +word-0+)))))) (defun aset-int16 (v a i) (declare (type int16 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +word-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +word-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card32)) #.(declare-buffun) (the card32 (logior (the card32 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card32 (v a i) (declare (type card32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-int32 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values int32)) #.(declare-buffun) (the int32 (logior (the int32 (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-int32 (v a i) (declare (type int32 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) (defun aref-card29 (a i) (declare (type buffer-bytes a) (type array-index i)) (declare (clx-values card29)) #.(declare-buffun) (the card29 (logior (the card29 (ash (the card8 (aref a (index+ i +long-3+))) 24)) (the card29 (ash (the card8 (aref a (index+ i +long-2+))) 16)) (the card16 (ash (the card8 (aref a (index+ i +long-1+))) 8)) (the card8 (aref a (index+ i +long-0+)))))) (defun aset-card29 (v a i) (declare (type card29 v) (type buffer-bytes a) (type array-index i)) #.(declare-buffun) (setf (aref a (index+ i +long-3+)) (the card8 (ldb (byte 8 24) v)) (aref a (index+ i +long-2+)) (the card8 (ldb (byte 8 16) v)) (aref a (index+ i +long-1+)) (the card8 (ldb (byte 8 8) v)) (aref a (index+ i +long-0+)) (the card8 (ldb (byte 8 0) v))) v) ) (defsetf aref-card8 (a i) (v) `(aset-card8 ,v ,a ,i)) (defsetf aref-int8 (a i) (v) `(aset-int8 ,v ,a ,i)) (defsetf aref-card16 (a i) (v) `(aset-card16 ,v ,a ,i)) (defsetf aref-int16 (a i) (v) `(aset-int16 ,v ,a ,i)) (defsetf aref-card32 (a i) (v) `(aset-card32 ,v ,a ,i)) (defsetf aref-int32 (a i) (v) `(aset-int32 ,v ,a ,i)) (defsetf aref-card29 (a i) (v) `(aset-card29 ,v ,a ,i)) ;;; Other random conversions (defun rgb-val->card16 (value) ;; Short floats are good enough (declare (type rgb-val value)) (declare (clx-values card16)) #.(declare-buffun) ;; Convert VALUE from float to card16 (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff))))) (defun card16->rgb-val (value) ;; Short floats are good enough (declare (type card16 value)) (declare (clx-values short-float)) #.(declare-buffun) ;; Convert VALUE from card16 to float (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff)))) (defun radians->int16 (value) ;; Short floats are good enough (declare (type angle value)) (declare (clx-values int16)) #.(declare-buffun) (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0))))) (defun int16->radians (value) ;; Short floats are good enough (declare (type int16 value)) (declare (clx-values short-float)) #.(declare-buffun) (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float)))) #+(or cmu sbcl clisp) (progn ;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI ;;; is irrational, there can't be a precise rational representation. In ;;; particular, the different float approximations will always be /=. This ;;; causes problems with type checking, because people might compute an ;;; argument in any precision. What we do is discard all the excess precision ;;; in the value, and see if the protocol encoding falls in the desired range ;;; (64'ths of a degree.) ;;; (deftype angle () '(satisfies anglep)) (defun anglep (x) (and (typep x 'real) (<= (* -360 64) (radians->int16 x) (* 360 64)))) ) ;;----------------------------------------------------------------------------- ;; Character transformation ;;----------------------------------------------------------------------------- ;;; This stuff transforms chars to ascii codes in card8's and back. ;;; You might have to hack it a little to get it to work for your machine. (declaim (inline char->card8 card8->char)) (macrolet ((char-translators () (let ((alist `(#-lispm ;; The normal ascii codes for the control characters. ,@`((#\Return . 13) (#\Linefeed . 10) (#\Rubout . 127) (#\Page . 12) (#\Tab . 9) (#\Backspace . 8) (#\Newline . 10) (#\Space . 32)) ;; One the lispm, #\Newline is #\Return, but we'd really like ;; #\Newline to translate to ascii code 10, so we swap the ;; Ascii codes for #\Return and #\Linefeed. We also provide ;; mappings from the counterparts of these control characters ;; so that the character mapping from the lisp machine ;; character set to ascii is invertible. #+lispm ,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return)) (#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed)) (#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout)) (#\Page . 12) (,(code-char 12) . ,(char-code #\Page)) (#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab)) (#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace)) (#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline)) (#\Space . 32) (,(code-char 32) . ,(char-code #\Space))) ;; The rest of the common lisp charater set with the normal ;; ascii codes for them. (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) (cond ((dolist (pair alist nil) (when (not (= (char-code (car pair)) (cdr pair))) (return t))) `(progn (defconstant *char-to-card8-translation-table* ',(let ((array (make-array (let ((max-char-code 255)) (dolist (pair alist) (setq max-char-code (max max-char-code (char-code (car pair))))) (1+ max-char-code)) :element-type 'card8))) (dotimes (i (length array)) (setf (aref array i) (mod i 256))) (dolist (pair alist) (setf (aref array (char-code (car pair))) (cdr pair))) array)) (defconstant *card8-to-char-translation-table* ',(let ((array (make-array 256))) (dotimes (i (length array)) (setf (aref array i) (code-char i))) (dolist (pair alist) (setf (aref array (cdr pair)) (car pair))) array)) #-Genera (progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (aref (the (simple-array card8 (*)) *char-to-card8-translation-table*) (the array-index (char-code char))))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (or (aref (the simple-vector *card8-to-char-translation-table*) card8) (error "Invalid CHAR code ~D." card8)))) ) #+Genera (progn (defun char->card8 (char) (declare lt:(side-effects reader reducible)) (aref *char-to-card8-translation-table* (char-code char))) (defun card8->char (card8) (declare lt:(side-effects reader reducible)) (aref *card8-to-char-translation-table* card8)) ) #-Minima (dotimes (i 256) (unless (= i (char->card8 (card8->char i))) (warn "The card8->char mapping is not invertible through char->card8. Info:~%~S" (list i (card8->char i) (char->card8 (card8->char i)))) (return nil))) #-Minima (dotimes (i (length *char-to-card8-translation-table*)) (let ((char (code-char i))) (unless (eql char (card8->char (char->card8 char))) (warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S" (list char (char->card8 char) (card8->char (char->card8 char)))) (return nil)))))) (t `(progn (defun char->card8 (char) (declare (type base-char char)) #.(declare-buffun) (the card8 (char-code char))) (defun card8->char (card8) (declare (type card8 card8)) #.(declare-buffun) (the base-char (code-char card8))) )))))) (char-translators)) ;;----------------------------------------------------------------------------- ;; Process Locking ;; ;; Common-Lisp doesn't provide process locking primitives, so we define ;; our own here, based on Zetalisp primitives. Holding-Lock is very ;; similar to with-lock on The TI Explorer, and a little more efficient ;; than with-process-lock on a Symbolics. ;;----------------------------------------------------------------------------- ;;; MAKE-PROCESS-LOCK: Creating a process lock. #-(or LispM excl Minima sbcl (and cmu mp)) (defun make-process-lock (name) (declare (ignore name)) nil) #+excl (defun make-process-lock (name) (mp:make-process-lock :name name)) #+(and LispM (not Genera)) (defun make-process-lock (name) (vector nil name)) #+Genera (defun make-process-lock (name) (process:make-lock name :flavor 'clx-lock)) #+Minima (defun make-process-lock (name) (minima:make-lock name :recursive t)) #+(and cmu mp) (defun make-process-lock (name) (mp:make-lock name)) #+sbcl (defun make-process-lock (name) (sb-thread:make-mutex :name name)) ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN ;;; passes its timeout to the holding-lock macro, so any timeout you want to ;;; work for event-listen you should do for holding-lock. ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient #-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) ) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect ;;; against re-entering request functions. This can happen if an interrupt ;;; occurs and the handler attempts to use X over the same display connection. ;;; This can happen if the GC hooks are used to notify the user over the same ;;; display connection. We inhibit GC notifications since display of them ;;; could cause recursive entry into CLX. ;;; #+(and CMU (not mp)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) `(let #+cmu((ext:*gc-verbose* nil) (ext:*gc-inhibit-hook* nil) (ext:*before-gc-hooks* nil) (ext:*after-gc-hooks* nil)) #+sbcl() ,locator ,display ,whostate ,timeout (system:without-interrupts (progn ,@body)))) ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes. ;;; #+(and cmu mp) (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) (declare (ignore display)) `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout))) ,@body)) #+clisp (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) (declare (ignore lock display whostate timeout)) `(progn ,@body)) #+sbcl (defmacro holding-lock ((lock display &optional (whostate "CLX wait") &key timeout) &body body) ;; This macro is used by WITH-DISPLAY, which claims to be callable ;; recursively. So, had better use a recursive lock. ;; ;; FIXME: This is hideously ugly. If WITH-TIMEOUT handled NIL ;; timeouts... (declare (ignore display whostate)) (if timeout `(if ,timeout (handler-case (sb-ext:with-timeout ,timeout (sb-thread:with-recursive-lock (,lock) ,@body)) (sb-ext:timeout () nil)) (sb-thread:with-recursive-lock (,lock) ,@body)) `(sb-thread:with-recursive-lock (,lock) ,@body))) #+Genera (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore whostate)) `(process:with-lock (,locator :timeout ,timeout) (let ((.debug-io. (buffer-debug-io ,display))) (scl:let-if .debug-io. ((*debug-io* .debug-io.)) ,@body)))) #+(and lispm (not Genera)) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) ;; This macro is for use in a multi-process environment. (let ((lock (gensym)) (have-lock (gensym)) (timeo (gensym))) `(let* ((,lock (zl:locf (svref ,locator 0))) (,have-lock (eq (car ,lock) sys:current-process)) (,timeo ,timeout)) (unwind-protect (when (cond (,have-lock) ((#+explorer si:%store-conditional #-explorer sys:store-conditional ,lock nil sys:current-process)) ((null ,timeo) (sys:process-lock ,lock nil ,(or whostate "CLX Lock"))) ((sys:process-wait-with-timeout ,(or whostate "CLX Lock") (round (* ,timeo 60.)) #'(lambda (lock process) (#+explorer si:%store-conditional #-explorer sys:store-conditional lock nil process)) ,lock sys:current-process))) ,@body) (unless ,have-lock (#+explorer si:%store-conditional #-explorer sys:store-conditional ,lock sys:current-process nil)))))) ;; Lucid has a process locking mechanism as well under release 3.0 #+lcl3.0 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) (if timeout ;; Hair to support timeout. `(let ((.have-lock. (eq ,locator lcl:*current-process*)) (.timeout. ,timeout)) (unwind-protect (when (cond (.have-lock.) ((conditional-store ,locator nil lcl:*current-process*)) ((null .timeout.) (lcl:process-lock ,locator) t) ((lcl:process-wait-with-timeout ,whostate .timeout. #'(lambda () (conditional-store ,locator nil lcl:*current-process*)))) ;; abort the PROCESS-UNLOCK if actually timing out (t (setf .have-lock. :abort) nil)) ,@body) (unless .have-lock. (lcl:process-unlock ,locator)))) `(lcl:with-process-lock (,locator) ,@body))) #+excl (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore display)) `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.) (unwind-protect (block .hl-doit. (when mp::*scheduler-stack-group* ; fast test for scheduler running (setq .hl-lock. ,locator .hl-curproc. mp::*current-process*) (when (and .hl-curproc. ; nil if in process-wait fun (not (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))) ;; Then we need to grab the lock. ,(if timeout `(if (not (mp::process-lock .hl-lock. .hl-curproc. ,whostate ,timeout)) (return-from .hl-doit. nil)) `(mp::process-lock .hl-lock. .hl-curproc. ,@(when whostate `(,whostate)))) ;; There is an apparent race condition here. However, there is ;; no actual race condition -- our implementation of mp:process- ;; lock guarantees that the lock will still be held when it ;; returns, and no interrupt can happen between that and the ;; execution of the next form. -- jdi 2/27/91 (setq .hl-obtained-lock. t))) ,@body) (if (and .hl-obtained-lock. ;; Note -- next form added to allow error handler inside ;; body to unlock the lock prematurely if it knows that ;; the current process cannot possibly continue but will ;; throw out (or is it throw up?). (eq (mp::process-lock-locker .hl-lock.) .hl-curproc.)) (mp::process-unlock .hl-lock. .hl-curproc.))))) #+Minima (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) `(holding-lock-1 #'(lambda () ,@body) ,locator ,display ,@(and whostate `(:whostate ,whostate)) ,@(and timeout `(:timeout ,timeout)))) #+Minima (defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout) (declare (dynamic-extent continuation)) (declare (ignore display whostate timeout)) (minima:with-lock (lock) (funcall continuation))) ;;; WITHOUT-ABORTS ;;; If you can inhibit asynchronous keyboard aborts inside the body of this ;;; macro, then it is a good idea to do this. This macro is wrapped around ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. #-(or Genera excl lcl3.0) (defmacro without-aborts (&body body) `(progn ,@body)) #+Genera (defmacro without-aborts (&body body) `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") ,@body)) #+excl (defmacro without-aborts (&body body) `(without-interrupts ,@body)) #+lcl3.0 (defmacro without-aborts (&body body) `(lcl:with-interruptions-inhibited ,@body)) ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value. ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. #-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp)) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler."))) #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #-clx-ansi-common-lisp (sys:downward-funarg predicate)) (apply #'process:block-process whostate predicate predicate-args)) #+(and lispm (not Genera)) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #-clx-ansi-common-lisp (sys:downward-funarg predicate)) (apply #'global:process-wait whostate predicate predicate-args)) #+excl (defun process-block (whostate predicate &rest predicate-args) (if mp::*scheduler-stack-group* (apply #'mp::process-wait whostate predicate predicate-args) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler.")))) #+lcl3.0 (defun process-block (whostate predicate &rest predicate-args) (declare (dynamic-extent predicate-args)) (apply #'lcl:process-wait whostate predicate predicate-args)) #+Minima (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) (dynamic-extent predicate)) (apply #'minima:process-wait whostate predicate predicate-args)) #+(and cmu mp) (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate)) (mp:process-wait whostate #'(lambda () (apply predicate predicate-args)))) #+(and sbcl sb-thread) (progn (declaim (inline yield)) (defun yield () (declare (optimize speed (safety 0))) (sb-alien:alien-funcall (sb-alien:extern-alien "sched_yield" (function sb-alien:int))) (values))) #+(and sbcl sb-thread) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (declare (type function predicate)) (loop (when (apply predicate predicate-args) (return)) (yield))) ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using ;;; queues and condition variables might seem better, but in fact it ;;; turns out to make performance extremely suboptimal, at least as ;;; measured by McCLIM on linux 2.4 kernels. -- CSR, 2003-11-10 #+(or) (defvar *process-conditions* (make-hash-table)) #+(or) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (declare (type function predicate)) (let* ((pid (sb-thread:current-thread-id)) (last (gethash pid *process-conditions*)) (lock (or (car last) (sb-thread:make-mutex :name (format nil "lock ~A" pid)))) (queue (or (cdr last) (sb-thread:make-waitqueue :name (format nil "queue ~A" pid))))) (unless last (setf (gethash pid *process-conditions*) (cons lock queue))) (sb-thread:with-mutex (lock) (loop (when (apply predicate predicate-args) (return)) (handler-case (sb-ext:with-timeout .5 (sb-thread:condition-wait queue lock)) (sb-ext:timeout () (format *trace-output* "thread ~A, process-block timed out~%" (sb-thread:current-thread-id) ))))))) ;;; PROCESS-WAKEUP: Check some other process' wait function. (declaim (inline process-wakeup)) #-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp)) (defun process-wakeup (process) (declare (ignore process)) nil) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) (when (and curproc process) (unless (mp::process-p curproc) (error "~s is not a process" curproc)) (unless (mp::process-p process) (error "~s is not a process" process)) (if (> (mp::process-priority process) (mp::process-priority curproc)) (mp::process-allow-schedule process))))) #+Genera (defun process-wakeup (process) (process:wakeup process)) #+Minima (defun process-wakeup (process) (when process (minima:process-wakeup process))) #+(and cmu mp) (defun process-wakeup (process) (declare (ignore process)) (mp:process-yield)) #+(and sb-thread sbcl) (defun process-wakeup (process) (declare (ignore process)) (yield)) #+(or) (defun process-wakeup (process) (declare (ignore process)) (destructuring-bind (lock . queue) (gethash (sb-thread:current-thread-id) *process-conditions* (cons nil nil)) (declare (ignore lock)) (when queue (sb-thread:condition-notify queue)))) ;;; CURRENT-PROCESS: Return the current process object for input locking and ;;; for calling PROCESS-WAKEUP. (declaim (inline current-process)) ;;; Default return NIL, which is acceptable even if there is a scheduler. #-(or lispm excl lcl3.0 sbcl Minima (and cmu mp)) (defun current-process () nil) #+lispm (defun current-process () sys:current-process) #+excl (defun current-process () (and mp::*scheduler-stack-group* mp::*current-process*)) #+lcl3.0 (defun current-process () lcl:*current-process*) #+Minima (defun current-process () (minima:current-process)) #+(and cmu mp) (defun current-process () mp:*current-process*) #+sbcl (defun current-process () sb-thread:*current-thread*) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. #-(or lispm excl lcl3.0 Minima cmu) (defmacro without-interrupts (&body body) `(progn ,@body)) #+(and lispm (not Genera)) (defmacro without-interrupts (&body body) `(sys:without-interrupts ,@body)) #+Genera (defmacro without-interrupts (&body body) `(process:with-no-other-processes ,@body)) #+LCL3.0 (defmacro without-interrupts (&body body) `(lcl:with-scheduling-inhibited ,@body)) #+Minima (defmacro without-interrupts (&body body) `(minima:with-no-other-processes ,@body)) #+cmu (defmacro without-interrupts (&body body) `(system:without-interrupts ,@body)) #+sbcl (defvar *without-interrupts-sic-lock* (sb-thread:make-mutex :name "lock simulating *without-interrupts*")) #+sbcl (defmacro without-interrupts (&body body) `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*) ,@body)) ;;; CONDITIONAL-STORE: ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times. ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD. #-sbcl (defmacro conditional-store (place old-value new-value) `(without-interrupts (cond ((eq ,place ,old-value) (setf ,place ,new-value) t)))) #+sbcl (progn (defvar *conditional-store-lock* (sb-thread:make-mutex :name "conditional store")) (defmacro conditional-store (place old-value new-value) `(sb-thread:with-mutex (*conditional-store-lock*) (cond ((eq ,place ,old-value) (setf ,place ,new-value) t))))) ;;;---------------------------------------------------------------------------- ;;; IO Error Recovery ;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro. ;;; It prevents multiple mindless errors when the network craters. ;;; ;;;---------------------------------------------------------------------------- #-Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(unless (buffer-dead ,buffer) ,@body)) #+Genera (defmacro wrap-buf-output ((buffer) &body body) ;; Error recovery wrapper `(let ((.buffer. ,buffer)) (unless (buffer-dead .buffer.) (scl:condition-bind (((sys:network-error) #'(lambda (error) (scl:condition-case () (funcall (buffer-close-function .buffer.) .buffer. :abort t) (sys:network-error)) (setf (buffer-dead .buffer.) error) (setf (buffer-output-stream .buffer.) nil) (setf (buffer-input-stream .buffer.) nil) nil))) ,@body)))) #-Genera (defmacro wrap-buf-input ((buffer) &body body) (declare (ignore buffer)) ;; Error recovery wrapper `(progn ,@body)) #+Genera (defmacro wrap-buf-input ((buffer) &body body) ;; Error recovery wrapper `(let ((.buffer. ,buffer)) (scl:condition-bind (((sys:network-error) #'(lambda (error) (scl:condition-case () (funcall (buffer-close-function .buffer.) .buffer. :abort t) (sys:network-error)) (setf (buffer-dead .buffer.) error) (setf (buffer-output-stream .buffer.) nil) (setf (buffer-input-stream .buffer.) nil) nil))) ,@body))) ;;;---------------------------------------------------------------------------- ;;; System dependent IO primitives ;;; Functions for opening, reading writing forcing-output and closing ;;; the stream to the server. ;;;---------------------------------------------------------------------------- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server #-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp) (defun open-x-stream (host display protocol) host display protocol ;; unused (error "OPEN-X-STREAM not implemented yet.")) #+clisp (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (let ((socket ;; are we dealing with a localhost? (when (or (string= host "") (string= host "unix")) ;; ok, try to connect to a AF_UNIX domain socket (sys::make-socket-stream "" display)))) (if socket socket ;; try to connect by hand (let ((host (host-address host))) (when host ;; Fixme: get a descent ip standard in CLX: a vector! (let ((ip (format nil "~{~D~^.~}" (rest host)))) (socket:socket-connect (+ 6000 display) ip :element-type '(unsigned-byte 8)))))))) ;;; Genera: ;;; TCP and DNA are both layered products, so try to work with either one. #+Genera (when (fboundp 'tcp:add-tcp-port-for-protocol) (tcp:add-tcp-port-for-protocol :x-window-system 6000)) #+Genera (when (fboundp 'dna:add-dna-contact-id-for-protocol) (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0")) #+Genera (net:define-protocol :x-window-system (:x-window-system :byte-stream) (:invoke-with-stream ((stream :characters nil :ascii-translation nil)) stream)) #+Genera (eval-when (compile) (compiler:function-defined 'tcp:open-tcp-stream) (compiler:function-defined 'dna:open-dna-bidirectional-stream)) #+Genera (defun open-x-stream (host display protocol) (let ((host (net:parse-host host))) (if (or protocol (plusp display)) ;; The protocol was specified or the display isn't 0, so we ;; can't use the Generic Network System. If the protocol was ;; specified, then use that protocol, otherwise, blindly use ;; TCP. (ccase protocol ((:tcp nil) (tcp:open-tcp-stream host (+ *x-tcp-port* display) nil :direction :io :characters nil :ascii-translation nil)) ((:dna) (dna:open-dna-bidirectional-stream host (format nil "X$X~D" display) :characters nil :ascii-translation nil))) (let ((neti:*invoke-service-automatic-retry* t)) (net:invoke-service-on-host :x-window-system host))))) #+explorer (defun open-x-stream (host display protocol) (declare (ignore protocol)) (net:open-connection-on-medium (net:parse-host host) ;Host :byte-stream ;Medium "X11" ;Logical contact name :stream-type :character-stream :direction :bidirectional :timeout-after-open nil :remote-port (+ *x-tcp-port* display))) #+explorer (net:define-logical-contact-name "X11" `((:local "X11") (:chaos "X11") (:nsp-stream "X11") (:tcp ,*x-tcp-port*))) #+lucid (defun open-x-stream (host display protocol) protocol ;; unused (let ((fd (connect-to-server host display))) (when (minusp fd) (error "Failed to connect to server: ~A ~D" host display)) (user::make-lisp-stream :input-handle fd :output-handle fd :element-type 'unsigned-byte #-lcl3.0 :stream-type #-lcl3.0 :ephemeral))) #+(or kcl ibcl) (defun open-x-stream (host display protocol) protocol ;; unused (let ((stream (open-socket-stream host display))) (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) #+excl ;; ;; Note that since we don't use the CL i/o facilities to do i/o, the display ;; input and output "stream" is really a file descriptor (fixnum). ;; (defun open-x-stream (host display protocol) (declare (ignore protocol));; unused (let ((fd (connect-to-server (string host) display))) (when (minusp fd) (error "Failed to connect to server: ~A ~D" host display)) fd)) #+Minima (defun open-x-stream (host display protocol) (declare (ignore protocol));; unused (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address (cdr (host-address host))) :foreign-port (+ *x-tcp-port* display))) #+CMU (defun open-x-stream (host display protocol) (let ((stream-fd (ecase protocol ;; establish a TCP connection to the X11 server, which is ;; listening on port 6000 + display-number ((:internet :tcp nil) (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display)))) (unless (plusp fd) (error 'connection-failure :major-version *protocol-major-version* :minor-version *protocol-minor-version* :host host :display display :reason (format nil "Cannot connect to internet socket: ~S" (unix:get-unix-error-msg)))) fd)) ;; establish a connection to the X11 server over a Unix ;; socket. (:|| comes from Darwin's weird DISPLAY ;; environment variable) ((:unix :local :||) (let ((path (unix-socket-path-from-host host display))) (unless (probe-file path) (error 'connection-failure :major-version *protocol-major-version* :minor-version *protocol-minor-version* :host host :display display :reason (format nil "Unix socket ~s does not exist" path))) (let ((fd (ext:connect-to-unix-socket (namestring path)))) (unless (plusp fd) (error 'connection-failure :major-version *protocol-major-version* :minor-version *protocol-minor-version* :host host :display display :reason (format nil "Can't connect to unix socket: ~S" (unix:get-unix-error-msg)))) fd)))))) (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) #+sbcl (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (let ((local-socket-path (unix-socket-path-from-host host display))) (socket-make-stream (if local-socket-path (let ((s (make-instance 'local-socket :type :stream))) (socket-connect s local-socket-path) s) (let ((host (car (host-ent-addresses (get-host-by-name host))))) (when host (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (socket-connect s host (+ 6000 display)) s)))) :element-type '(unsigned-byte 8) :input t :output t :buffering :none))) #+ecl (defun open-x-stream (host display protocol) (declare (ignore protocol) (type (integer 0) display)) (let (socket) (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket (sys::open-unix-socket-stream (format nil "~A~D" +X-unix-socket-path+ display)) (si::open-client-stream host (+ 6000 display))))) ;;; BUFFER-READ-DEFAULT - read data from the X stream #+(or Genera explorer) (defun buffer-read-default (display vector start end timeout) ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) ((funcall stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (multiple-value-bind (ignore eofp) (funcall stream :string-in nil vector start end) eofp)))) #+excl ;; ;; Rewritten 10/89 to not use foreign function interface to do I/O. ;; (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let* ((howmany (- end start)) (fd (display-input-stream display))) (declare (type array-index howmany) (fixnum fd)) (or (cond ((fd-char-avail-p fd) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (fd-read-bytes fd vector start howmany)))) #+lcl3.0 (defmacro with-underlying-stream ((variable stream display direction) &body body) `(let ((,variable (or (getf (display-plist ,display) ',direction) (setf (getf (display-plist ,display) ',direction) (lucid::underlying-stream ,stream ,(if (eq direction 'input) :input :output)))))) ,@body)) #+lcl3.0 (defun buffer-read-default (display vector start end timeout) ;;Note that LISTEN must still be done on "slow stream" or the I/O system ;;gets confused. But reading should be done from "fast stream" for speed. ;;We used to inhibit scheduling because there were races in Lucid's ;;multitasking system. Empirical evidence suggests they may be gone now. ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:read-array. (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (with-underlying-stream (stream stream display input) (eq (lcl:read-array stream vector start end nil :eof) :eof))))) #+Minima (defun buffer-read-default (display vector start end timeout) ;; returns non-NIL if EOF encountered ;; Returns :TIMEOUT when timeout exceeded (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (eq :eof (minima:read-vector vector stream nil start end))))) ;;; BUFFER-READ-DEFAULT for CMU Common Lisp. ;;; ;;; If timeout is 0, then we call LISTEN to see if there is any input. ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without ;;; first calling BUFFER-INPUT-WAIT-DEFAULT. ;;; #+(or CMU sbcl) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t (#+cmu system:read-n-bytes #+sbcl sb-sys:read-n-bytes (display-input-stream display) vector start (- end start)) nil))) #+(or ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null fixnum) timeout)) #.(declare-buffun) (cond ((and (eql timeout 0) (not (listen (display-input-stream display)))) :timeout) (t (read-sequence vector (display-input-stream display) :start start :end end) nil))) ;;; WARNING: ;;; CLX performance will suffer if your lisp uses read-byte for ;;; receiving all data from the X Window System server. ;;; You are encouraged to write a specialized version of ;;; buffer-read-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) (type array-index start end) (type (or null (real 0 *)) timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (or (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((buffer-input-wait-default display timeout))) (do* ((index start (index1+ index))) ((index>= index end) nil) (declare (type array-index index)) (let ((c (read-byte stream nil nil))) (declare (type (or null card8) c)) (if (null c) (return t) (setf (aref vector index) (the card8 c)))))))) ;;; BUFFER-WRITE-DEFAULT - write data to the X stream #+(or Genera explorer) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (write-string vector stream :start start :end end)))) #+excl (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (excl::filesys-write-bytes (display-output-stream display) vector start (- end start))) #+lcl3.0 (defun buffer-write-default (vector display start end) ;;We used to inhibit scheduling because there were races in Lucid's ;;multitasking system. Empirical evidence suggests they may be gone now. ;;Should you decide you need to inhibit scheduling, do it around the ;;lcl:write-array. (declare (type display display) (type buffer-bytes vector) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-underlying-stream (stream stream display output) (lcl:write-array stream vector start end))))) #+Minima (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (minima:write-vector vector stream start end)))) #+CMU (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (system:output-raw-bytes (display-output-stream display) vector start end) nil) #+(or sbcl ecl clisp) (defun buffer-write-default (vector display start end) (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (write-sequence vector (display-output-stream display) :start start :end end) nil) ;;; WARNING: ;;; CLX performance will be severely degraded if your lisp uses ;;; write-byte to send all data to the X Window System server. ;;; You are STRONGLY encouraged to write a specialized version ;;; of buffer-write-default that does block transfers. #-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) (type display display) (type array-index start end)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (with-vector (vector buffer-bytes) (do ((index start (index1+ index))) ((index>= index end)) (declare (type array-index index)) (write-byte (aref vector index) stream)))))) ;;; buffer-force-output-default - force output to the X stream #+excl (defun buffer-force-output-default (display) ;; buffer-write-default does the actual writing. (declare (ignore display))) #-(or excl) (defun buffer-force-output-default (display) ;; The default buffer force-output function for use with common-lisp streams (declare (type display display)) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (force-output stream)))) ;;; BUFFER-CLOSE-DEFAULT - close the X stream #+excl (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display) (ignore abort)) #.(declare-buffun) (excl::filesys-checking-close (display-output-stream display))) #-(or excl) (defun buffer-close-default (display &key abort) ;; The default buffer close function for use with common-lisp streams (declare (type display display)) #.(declare-buffun) (let ((stream (display-output-stream display))) (declare (type (or null stream) stream)) (unless (null stream) (close stream :abort abort)))) ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the ;;; buffer. This is called in read-input between requests, so that a process ;;; waiting for input is abortable when between requests. Should return ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation ;; Poll for input every *buffer-read-polling-time* SECONDS. #-(or Genera explorer excl lcl3.0 CMU sbcl) (defparameter *buffer-read-polling-time* 0.5) #-(or Genera explorer excl lcl3.0 CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((not (null timeout)) (multiple-value-bind (npoll fraction) (truncate timeout *buffer-read-polling-time*) (dotimes (i npoll) ; Sleep for a time, then listen again (sleep *buffer-read-polling-time*) (when (listen stream) (return-from buffer-input-wait-default nil))) (when (plusp fraction) (sleep fraction) ; Sleep a fraction of a second (when (listen stream) ; and listen one last time (return-from buffer-input-wait-default nil))) :timeout))))) #+(or CMU sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) (t (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) (ext:socket-status stream (and timeout sec) (round usec 1d-6))) #-(or sbcl mp clisp) (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) nil :timeout))))) #+Genera (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((scl:send stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((null timeout) (si:stream-input-block stream "CLX Input")) (t (scl:condition-bind ((neti:protocol-timeout #'(lambda (error) (when (eq stream (scl:send error :stream)) (return-from buffer-input-wait-default :timeout))))) (neti:with-stream-timeout (stream :input timeout) (si:stream-input-block stream "CLX Input"))))) nil)) #+explorer (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((zl:send stream :listen) nil) ((and timeout (= timeout 0)) :timeout) ((null timeout) (si:process-wait "CLX Input" stream :listen)) (t (unless (si:process-wait-with-timeout "CLX Input" (round (* timeout 60.)) stream :listen) (return-from buffer-input-wait-default :timeout)))) nil)) #+excl ;; ;; This is used so an 'eq' test may be used to find out whether or not we can ;; safely throw this process out of the CLX read loop. ;; (defparameter *read-whostate* "waiting for input from X server") ;; ;; Note that this function returns nil on error if the scheduler is running, ;; t on error if not. This is ok since buffer-read will detect the error. ;; #+excl (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout)) (declare (clx-values timeout)) (let ((fd (display-input-stream display))) (declare (fixnum fd)) (when (>= fd 0) (cond ((fd-char-avail-p fd) nil) ;; Otherwise no bytes were available on the socket ((and timeout (= timeout 0)) ;; If there aren't enough and timeout == 0, timeout. :timeout) ;; If the scheduler is running let it do timeouts. (mp::*scheduler-stack-group* #+allegro (if (not (mp:wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p :timeout timeout)) (return-from buffer-input-wait-default :timeout)) #-allegro (mp::wait-for-input-available fd :whostate *read-whostate* :wait-function #'fd-char-avail-p)) ;; Otherwise we have to handle timeouts by hand, and call select() ;; to block until input is available. Note we don't really handle ;; the interaction of interrupts and (numberp timeout) here. XX (t (let ((res 0)) (declare (fixnum res)) (with-interrupt-checking-on (loop (setq res (fd-wait-for-input fd (if (null timeout) 0 (truncate timeout)))) (cond ((plusp res) ; success (return nil)) ((eq res 0) ; timeout (return :timeout)) ((eq res -1) ; error (return t)) ;; Otherwise we got an interrupt -- go around again. ))))))))) #+lcl3.0 (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null (real 0 *)) timeout) (clx-values timeout)) #.(declare-buffun) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) ((and timeout (= timeout 0)) :timeout) ((with-underlying-stream (stream stream display input) (lucid::waiting-for-input-from-stream stream (lucid::with-io-unlocked (if (null timeout) (lcl:process-wait "CLX Input" #'listen stream) (lcl:process-wait-with-timeout "CLX Input" timeout #'listen stream))))) nil) (:timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ;;; The default implementation is to just use listen. #-(or excl) (defun buffer-listen-default (display) (declare (type display display)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (if (null stream) t (listen stream)))) #+excl (defun buffer-listen-default (display) (declare (type display display)) (let ((fd (display-input-stream display))) (declare (type fixnum fd)) (if (= fd -1) t (fd-char-avail-p fd)))) ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks ;;;---------------------------------------------------------------------------- ;; ;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature. ;; If your lisp doesn't have stack-lists, and you're worried about ;; consing garbage, you may want to re-write this to allocate and ;; initialize lists from a resource. ;; #-lispm (defmacro with-stack-list ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body) ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) #-lispm (defmacro with-stack-list* ((var &rest elements) &body body) ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body) ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body) ;; except that the list produced by MAPCAR resides on the stack and ;; therefore DISAPPEARS when WITH-STACK-LIST is exited. `(let ((,var (list* ,@elements))) (declare (type cons ,var) #+clx-ansi-common-lisp (dynamic-extent ,var)) ,@body)) (declaim (inline buffer-replace)) #+lispm (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) (type array-index start1 end1 start2)) (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1)) #+excl (defun buffer-replace (target-sequence source-sequence target-start target-end &optional (source-start 0)) (declare (type buffer-bytes target-sequence source-sequence) (type array-index target-start target-end source-start) (optimize (speed 3) (safety 0))) (let ((source-end (length source-sequence))) (declare (type array-index source-end)) (excl:if* (and (eq target-sequence source-sequence) (> target-start source-start)) then (let ((nelts (min (- target-end target-start) (- source-end source-start)))) (do ((target-index (+ target-start nelts -1) (1- target-index)) (source-index (+ source-start nelts -1) (1- source-index))) ((= target-index (1- target-start)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) else (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index))) ((or (= target-index target-end) (= source-index source-end)) target-sequence) (declare (type array-index target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))))) #+cmu (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) #.(declare-buffun) (kernel:bit-bash-copy buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)) (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits))) #+lucid ;;;The compiler is *supposed* to optimize calls to replace, but in actual ;;;fact it does not. (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) #.(declare-buffun) (let ((end2 (lucid::%simple-8bit-vector-length buf2))) (declare (type array-index end2)) (lucid::simple-8bit-vector-replace-internal buf1 buf2 start1 end1 start2 end2))) #+(and clx-overlapping-arrays (not (or lispm excl))) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type vector buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #-(or lispm lucid excl CMU clx-overlapping-arrays) (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0)) (declare (type buffer-bytes buf1 buf2) (type array-index start1 end1 start2)) (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2)) #+ti (defun with-location-bindings (sys:"e bindings &rest body) (do ((bindings bindings (cdr bindings))) ((null bindings) (sys:eval-body-as-progn body)) (sys:bind (sys:*eval `(sys:locf ,(caar bindings))) (sys:*eval (cadar bindings))))) #+ti (compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form) (let ((bindings (cadr form)) (body (cddr form))) `(let () ,@(loop for (accessor value) in bindings collect `(si:bind (si:locf ,accessor) ,value)) ,@body))) #+ti (defun (:property with-location-bindings compiler::cw-handler) (exp) (let* ((bindlist (mapcar #'compiler::cw-clause (second exp))) (body (compiler::cw-clause (cddr exp)))) (and compiler::cw-return-expansion-flag (list* (first exp) bindlist body)))) #+(and lispm (not ti)) (defmacro with-location-bindings (bindings &body body) `(sys:letf* ,bindings ,@body)) #+lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) ;; don't use svref on LHS because Symbolics didn't define locf for it (let* ((local-state (gensym)) (bindings `(((aref ,local-state ,ts-index) 0)))) ; will become zero anyway (dolist (index indexes) (push `((aref ,local-state ,index) (svref ,saved-state ,index)) bindings)) `(let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) (unwind-protect (with-location-bindings ,bindings ,@body) (setf (svref ,local-state ,ts-index) 0) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state))))) #-lispm (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc) &body body) (let ((local-state (gensym)) (resets nil)) (dolist (index indexes) (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index)) resets)) `(unwind-protect (progn ,@body) (let ((,local-state (gcontext-local-state ,gc))) (declare (type gcontext-state ,local-state)) ,@resets (setf (svref ,local-state ,ts-index) 0)) (when ,temp-gc (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc)) (deallocate-gcontext-state ,saved-state)))) ;;;---------------------------------------------------------------------------- ;;; How much error detection should CLX do? ;;; Several levels are possible: ;;; ;;; 1. Do the equivalent of check-type on every argument. ;;; ;;; 2. Simply report TYPE-ERROR. This eliminates overhead of all the format ;;; strings generated by check-type. ;;; ;;; 3. Do error checking only on arguments that are likely to have errors ;;; (like keyword names) ;;; ;;; 4. Do error checking only where not doing so may dammage the envirnment ;;; on a non-tagged machine (i.e. when storing into a structure that has ;;; been passed in) ;;; ;;; 5. No extra error detection code. On lispm's, ASET may barf trying to ;;; store a non-integer into a number array. ;;; ;;; How extensive should the error checking be? For example, if the server ;;; expects a CARD16, is is sufficient for CLX to check for integer, or ;;; should it also check for non-negative and less than 65536? ;;;---------------------------------------------------------------------------- ;; The +TYPE-CHECK?+ constant controls how much error checking is done. ;; Possible values are: ;; NIL - Don't do any error checking ;; t - Do the equivalent of checktype on every argument ;; :minimal - Do error checking only where errors are likely ;;; This controls macro expansion, and isn't changable at run-time You will ;;; probably want to set this to nil if you want good performance at ;;; production time. (defconstant +type-check?+ #+(or Genera Minima CMU sbcl) nil #-(or Genera Minima CMU sbcl) t) ;; TYPE? is used to allow the code to do error checking at a different level from ;; the declarations. It also does some optimizations for systems that don't have ;; good compiler support for TYPEP. The definitions for CARD32, CARD16, INT16, etc. ;; include range checks. You can modify TYPE? to do less extensive checking ;; for these types if you desire. ;; ;; ### This comment is a lie! TYPE? is really also used for run-time type ;; dispatching, not just type checking. -- Ram. (defmacro type? (object type) #+(or cmu sbcl clisp) `(typep ,object ,type) #-(or cmu sbcl clisp) (if (not (constantp type)) `(typep ,object ,type) (progn (setq type (eval type)) #+(or Genera explorer Minima) (if +type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type)) `(typep ,object ',type)) #-(or Genera explorer Minima) (let ((predicate (assoc type '((drawable drawable-p) (window window-p) (pixmap pixmap-p) (cursor cursor-p) (font font-p) (gcontext gcontext-p) (colormap colormap-p) (null null) (integer integerp))))) (cond (predicate `(,(second predicate) ,object)) ((eq type 'generalized-boolean) 't) ; Everything is a generalized-boolean. (+type-check?+ `(locally (declare (optimize safety)) (typep ,object ',type))) (t `(typep ,object ',type))))))) ;; X-TYPE-ERROR is the function called for type errors. ;; If you want lots of checking, but are concerned about code size, ;; this can be made into a macro that ignores some parameters. (defun x-type-error (object type &optional error-string) (x-error 'x-type-error :datum object :expected-type type :type-string error-string)) ;;----------------------------------------------------------------------------- ;; Error handlers ;; Hack up KMP error signaling using zetalisp until the real thing comes ;; along ;;----------------------------------------------------------------------------- (defun default-error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) (declare (type generalized-boolean asynchronous) (dynamic-extent key-vals)) ;; The default display-error-handler. ;; It signals the conditions listed in the DISPLAY file. (if asynchronous (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals) (apply #'x-error error-key :display display :error-key error-key key-vals))) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (defun x-error (condition &rest keyargs) (apply #'sys:signal condition keyargs)) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (defun x-cerror (proceed-format-string condition &rest keyargs) (sys:signal (apply #'zl:make-condition condition keyargs) :proceed-types proceed-format-string)) #+(and Genera (not clx-ansi-common-lisp)) (defun x-error (condition &rest keyargs) (declare (dbg:error-reporter)) (apply #'sys:signal condition keyargs)) #+(and Genera (not clx-ansi-common-lisp)) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dbg:error-reporter)) (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp)) (defun x-error (condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'error condition keyargs)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'cerror proceed-format-string condition keyargs)) ;;; X-ERROR for CMU Common Lisp ;;; ;;; We detect a couple condition types for which we disable event handling in ;;; our system. This prevents going into the debugger or returning to a ;;; command prompt with CLX repeatedly seeing the same condition. This occurs ;;; because CMU Common Lisp provides for all events (that is, X, input on file ;;; descriptors, Mach messages, etc.) to come through one routine anyone can ;;; use to wait for input. ;;; #+(and CMU (not mp)) (defun x-error (condition &rest keyargs) (let ((condx (apply #'make-condition condition keyargs))) (when (eq condition 'closed-display) (let ((disp (closed-display-display condx))) (warn "Disabled event handling on ~S." disp) (ext::disable-clx-event-handling disp))) (error condx))) #-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-error (condition &rest keyargs) (error "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun x-cerror (proceed-format-string condition &rest keyargs) (cerror proceed-format-string "X-Error: ~a" (princ-to-string (apply #'make-condition condition keyargs)))) ;; version 15 of Pitman error handling defines the syntax for define-condition to be: ;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*] ;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string) ;; or (:report exp) #+lcl3.0 (defmacro define-condition (name parent-types &optional slots &rest args) `(lcl:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and excl (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(excl::define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and CMU (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &optional slots &rest args) `(common-lisp:define-condition ,name (,(first parent-types)) ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) slots) ,@args)) #+(and lispm (not clx-ansi-common-lisp)) (defmacro define-condition (name parent-types &body options) (let ((slot-names (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) (pop options))) (documentation nil) (conc-name (concatenate 'string (string name) "-")) (reporter nil)) (dolist (item options) (ecase (first item) (:documentation (setq documentation (second item))) (:conc-name (setq conc-name (string (second item)))) (:report (setq reporter (second item))))) `(within-definition (,name define-condition) (zl:defflavor ,name ,slot-names ,parent-types :initable-instance-variables #-Genera (:accessor-prefix ,conc-name) #+Genera (:conc-name ,conc-name) #-Genera (:outside-accessible-instance-variables ,@slot-names) #+Genera (:readable-instance-variables ,@slot-names)) ,(when reporter ;; when no reporter, parent's is inherited `(zl:defmethod #-Genera (,name :report) #+Genera (dbg:report ,name) (stream) ,(if (stringp reporter) `(write-string ,reporter stream) `(,reporter global:self stream)) global:self)) (zl:compile-flavor-methods ,name) ,(when documentation `(setf (documentation name 'type) ,documentation)) ',name))) #+(and lispm (not Genera) (not clx-ansi-common-lisp)) (zl:defflavor x-error () (global:error)) #+(and Genera (not clx-ansi-common-lisp)) (scl:defflavor x-error ((dbg:proceed-types '(:continue)) ; continue-format-string) (sys:error) (:initable-instance-variables continue-format-string)) #+(and Genera (not clx-ansi-common-lisp)) (scl:defmethod (scl:make-instance x-error) (&rest ignore) (when (not (sys:variable-boundp continue-format-string)) (setf dbg:proceed-types (remove :continue dbg:proceed-types)))) #+(and Genera (not clx-ansi-common-lisp)) (scl:defmethod (dbg:proceed x-error :continue) () :continue) #+(and Genera (not clx-ansi-common-lisp)) (sys:defmethod (dbg:document-proceed-type x-error :continue) (stream) (format stream continue-format-string)) #+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition x-error (error) ()) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defstruct x-error report-function) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl) (defmacro define-condition (name parent-types &body options) ;; Define a structure that when printed displays an error message (flet ((reporter-for-condition (name) (xintern "." name '-reporter.))) (let ((slot-names (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot)) (pop options))) (documentation nil) (conc-name (concatenate 'string (string name) "-")) (reporter nil) (condition (gensym)) (stream (gensym)) (report-function (reporter-for-condition name))) (dolist (item options) (ecase (first item) (:documentation (setq documentation (second item))) (:conc-name (setq conc-name (string (second item)))) (:report (setq reporter (second item))))) (unless reporter (setq report-function (reporter-for-condition (first parent-types)))) `(within-definition (,name define-condition) (defstruct (,name (:conc-name ,(intern conc-name)) (:print-function condition-print) (:include ,(first parent-types) (report-function ',report-function))) ,@slot-names) ,(when documentation `(setf (documentation name 'type) ,documentation)) ,(when reporter `(defun ,report-function (,condition ,stream) ,(if (stringp reporter) `(write-string ,reporter ,stream) `(,reporter ,condition ,stream)) ,condition)) ',name)))) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun condition-print (condition stream depth) (declare (type x-error condition) (type stream stream) (ignore depth)) (if *print-escape* (print-unreadable-object (condition stream :type t)) (funcall (x-error-report-function condition) condition stream)) condition) #-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (defun make-condition (type &rest slot-initializations) (declare (dynamic-extent slot-initializations)) (let ((make-function (intern (concatenate 'string (string 'make-) (string type)) (symbol-package type)))) (apply make-function slot-initializations))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp) (define-condition type-error (x-error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report (lambda (condition stream) (format stream "~s isn't a ~a" (type-error-datum condition) (type-error-expected-type condition))))) ;;----------------------------------------------------------------------------- ;; HOST hacking ;;----------------------------------------------------------------------------- #-(or explorer Genera Minima Allegro CMU sbcl ecl clisp) (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) host family (error "HOST-ADDRESS not implemented yet.")) #+clisp (defun host-address (host &optional (family :internet)) "Return a list whose car is the family keyword (:internet :DECnet :Chaos) and cdr is a list of network address bytes." (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent (posix::resolve-host-ipaddr (string host)))) (when (not (posix::hostent-addr-list hostent)) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (posix::hostent-addrtype hostent) 2) (no-address-error)) (let ((addr (first (posix::hostent-addr-list hostent)))) (etypecase addr (integer (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))) (string (let ((parts (read-from-string (nsubstitute #\Space #\. (ext:string-concat "(" addr ")"))))) (check-type parts (cons (unsigned-byte 8) (cons (unsigned-byte 8) (cons (unsigned-byte 8) (cons (unsigned-byte 8) NULL))))) (cons :internet parts)))))))))) #+explorer (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (ecase family ((:internet nil 0) (let ((addr (ip:get-ip-address host))) (unless addr (error "~s isn't an internet host name" host)) (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr)))) ((:chaos 2) (let ((addr (first (chaos:chaos-addresses host)))) (unless addr (error "~s isn't a chaos host name" host)) (list :chaos (ldb (byte 8 0) addr) (ldb (byte 8 8) addr)))))) #+Genera (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (setf host (string host)) (let ((net-type (ecase family ((:internet nil 0) :internet) ((:DECnet 1) :dna) ((:chaos 2) :chaos)))) (dolist (addr (sys:send (net:parse-host host) :network-addresses) (error "~S isn't a valid ~(~A~) host name" host family)) (let ((network (car addr)) (address (cadr addr))) (when (sys:send network :network-typep net-type) (return (ecase family ((:internet nil 0) (multiple-value-bind (a b c d) (tcp:explode-internet-address address) (list :internet a b c d))) ((:DECnet 1) (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address))) ((:chaos 2) (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address)))))))))) #+Minima (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (etypecase family ((:internet nil 0) (list* :internet (multiple-value-list (minima:ip-address-components (minima:parse-ip-address (string host)))))))) #+Allegro (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent 0)) (unwind-protect (progn (setf hostent (ipc::gethostbyname (string host))) (when (zerop hostent) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (ipc::hostent-addrtype hostent) 2) (no-address-error)) (assert (= (ipc::hostent-length hostent) 4)) (let ((addr (ipc::hostent-addr hostent))) (when (or (member comp::.target. '(:hp :sgi4d :sony :dec3100) :test #'eq) (probe-file "/lib/ld.so")) ;; BSD 4.3 based systems require an extra indirection (setq addr (si:memref-int addr 0 0 :unsigned-long))) (list :internet (si:memref-int addr 0 0 :unsigned-byte) (si:memref-int addr 1 0 :unsigned-byte) (si:memref-int addr 2 0 :unsigned-byte) (si:memref-int addr 3 0 :unsigned-byte)))))) (ff:free-cstruct hostent))))) #+CMU (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host)) (no-address-error () (error "Host ~S has no ~S address" host family))) (let ((hostent (ext:lookup-host-entry (string host)))) (when (not hostent) (no-host-error)) (ecase family ((:internet nil 0) (unless (= (ext::host-entry-addr-type hostent) 2) (no-address-error)) (append (list :internet) (let ((addr (first (ext::host-entry-addr-list hostent)))) (list (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))))))) ;#+sbcl ;(require :sockets) #+sbcl (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (let ((hostent (get-host-by-name (string host)))) (ecase family ((:internet nil 0) (cons :internet (coerce (host-ent-address hostent) 'list)))))) #+ecl (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type stringable host) (type (or null (member :internet :decnet :chaos) card8) family)) (declare (clx-values list)) (labels ((no-host-error () (error "Unknown host ~S" host))) (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host)))))) (unless addr (no-host-error)) (list :internet (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))))) #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let* ((family (first host-object)) (address (ecase family (:internet (dpb (second host-object) (byte 8 24) (dpb (third host-object) (byte 8 16) (dpb (fourth host-object) (byte 8 8) (fifth host-object))))) (:chaos (dpb (third host-object) (byte 8 8) (second host-object)))))) (when (eq family :internet) (setq family :ip)) (let ((host (si:get-host-from-address address family))) (values (and host (funcall host :name)) family)))) ;;; This isn't required, but it helps make sense of the results from access-hosts #+Genera (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let ((family (first host-object))) (values (sys:send (net:get-host-from-address (ecase family (:internet (apply #'tcp:build-internet-address (rest host-object))) ((:chaos :DECnet) (dpb (third host-object) (byte 8 8) (second host-object)))) (net:local-network-of-type (if (eq family :DECnet) :DNA family))) :name) family))) ;;; This isn't required, but it helps make sense of the results from access-hosts #+Minima (defun get-host (host-object) ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos) ;; and cdr is a list of network address bytes. (declare (type list host-object)) (declare (clx-values string family)) (let ((family (first host-object))) (values (ecase family (:internet (minima:ip-address-string (apply #'minima:make-ip-address (rest host-object))))) family))) ;;----------------------------------------------------------------------------- ;; Whether to use closures for requests or not. ;;----------------------------------------------------------------------------- ;;; If this macro expands to non-NIL, then request and locking code is ;;; compiled in a much more compact format, as the common code is shared, and ;;; the specific code is built into a closure that is funcalled by the shared ;;; code. If your compiler makes efficient use of closures then you probably ;;; want to make this expand to T, as it makes the code more compact. (defmacro use-closures () #+(or lispm Minima) t #-(or lispm Minima) nil) #+(or Genera Minima) (defun clx-macroexpand (form env) (declare (ignore env)) form) #-(or Genera Minima) (defun clx-macroexpand (form env) (macroexpand form env)) ;;----------------------------------------------------------------------------- ;; Resource stuff ;;----------------------------------------------------------------------------- ;;; Utilities (defun getenv (name) #+excl (sys:getenv name) #+lcl3.0 (lcl:environment-variable name) #+CMU (cdr (assoc name ext:*environment-list* :test #'string=)) #+sbcl (sb-ext:posix-getenv name) #+ecl (si:getenv name) #+clisp (ext:getenv name) #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil)) (defun get-host-name () "Return the same hostname as gethostname(3) would" ;; machine-instance probably works on a lot of lisps, but clisp is not ;; one of them #+(or cmu sbcl) (machine-instance) ;; resources-pathname was using short-site-name for this purpose #+excl (short-site-name) #+ecl (si:getenv "HOST") #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s))) #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented")) (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if ;;; a resource manager isn't running. (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. (defun resources-pathname () (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) (homedir-file-pathname (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. (defun authority-pathname () (or (let ((xauthority (getenv "XAUTHORITY"))) (and xauthority (pathname xauthority))) (homedir-file-pathname ".Xauthority"))) ;;; this particular defaulting behaviour is typical to most Unices, I think #+unix (defun get-default-display (&optional display-name) "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY if it is NIL. Display names have the format [protocol/] [hostname] : [:] displaynumber [.screennumber] There are two special cases in parsing, to match that done in the Xlib C language bindings - If the hostname is ``unix'' or the empty string, any supplied protocol is ignored and a connection is made using the :local transport. - If a double colon separates hostname from displaynumber, the protocol is assumed to be decnet. Returns a list of (host display-number screen protocol)." (let* ((name (or display-name (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (slash-i (or (position #\/ name) -1)) (colon-i (position #\: name :start (1+ slash-i))) (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) (host (subseq name (1+ slash-i) colon-i)) (dot-i (and colon-i (position #\. name :start colon-i))) (display (when colon-i (parse-integer name :start (if decnet-colon-p (+ colon-i 2) (1+ colon-i)) :end dot-i))) (screen (when dot-i (parse-integer name :start (1+ dot-i)))) (protocol (cond ((or (string= host "") (string-equal host "unix")) :local) (decnet-colon-p :decnet) ((> slash-i -1) (intern (string-upcase (subseq name 0 slash-i)) :keyword)) (t :internet)))) (list host (or display 0) (or screen 0) protocol))) ;;----------------------------------------------------------------------------- ;; GC stuff ;;----------------------------------------------------------------------------- (defun gc-cleanup () (declare (special *event-free-list* *pending-command-free-list* *reply-buffer-free-lists* *gcontext-local-state-cache* *temp-gcontext-cache*)) (setq *event-free-list* nil) (setq *pending-command-free-list* nil) (when (boundp '*reply-buffer-free-lists*) (fill *reply-buffer-free-lists* nil)) (setq *gcontext-local-state-cache* nil) (setq *temp-gcontext-cache* nil) nil) #+Genera (si:define-gc-cleanup clx-cleanup ("CLX Cleanup") (gc-cleanup)) ;;----------------------------------------------------------------------------- ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND) ;;----------------------------------------------------------------------------- #-(or clx-ansi-common-lisp Genera CMU sbcl) (defun with-standard-io-syntax-function (function) (declare #+lispm (sys:downward-funarg function)) (let ((*package* (find-package :user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-pretty* nil) (*print-radix* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-suppress* nil) #+ticl (ticl:*print-structure* t) #+lucid (lucid::*print-structure* t)) (funcall function))) #-(or clx-ansi-common-lisp Genera CMU sbcl) (defmacro with-standard-io-syntax (&body body) `(flet ((.with-standard-io-syntax-body. () ,@body)) (with-standard-io-syntax-function #'.with-standard-io-syntax-body.))) ;;----------------------------------------------------------------------------- ;; DEFAULT-KEYSYM-TRANSLATE ;;----------------------------------------------------------------------------- ;;; If object is a character, char-bits are set from state. ;;; ;;; [the following isn't implemented (should it be?)] ;;; If object is a list, it is an alist with entries: ;;; (base-char [modifiers] [mask-modifiers]) ;;; When MODIFIERS are specified, this character translation ;;; will only take effect when the specified modifiers are pressed. ;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;;; In ambiguous cases, the most specific translation is used. #-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (clx-values t) (special left-meta-keysym right-meta-keysym left-super-keysym right-super-keysym left-hyper-keysym right-hyper-keysym)) (when (characterp object) (when (logbitp (position :control +state-mask-vector+) state) (setf (char-bit object :control) 1)) (when (or (state-keysymp display state left-meta-keysym) (state-keysymp display state right-meta-keysym)) (setf (char-bit object :meta) 1)) (when (or (state-keysymp display state left-super-keysym) (state-keysymp display state right-super-keysym)) (setf (char-bit object :super) 1)) (when (or (state-keysymp display state left-hyper-keysym) (state-keysymp display state right-hyper-keysym)) (setf (char-bit object :hyper) 1))) object) #+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp) (defun default-keysym-translate (display state object) (declare (type display display) (type card16 state) (type t object) (ignore display state) (clx-values t)) object) ;;----------------------------------------------------------------------------- ;; Image stuff ;;----------------------------------------------------------------------------- ;;; Types (deftype pixarray-1-element-type () 'bit) (deftype pixarray-4-element-type () '(unsigned-byte 4)) (deftype pixarray-8-element-type () '(unsigned-byte 8)) (deftype pixarray-16-element-type () '(unsigned-byte 16)) (deftype pixarray-24-element-type () '(unsigned-byte 24)) (deftype pixarray-32-element-type () #-(or Genera Minima) '(unsigned-byte 32) #+(or Genera Minima) 'fixnum) (deftype pixarray-1 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-1-element-type (* *))) (deftype pixarray-4 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-4-element-type (* *))) (deftype pixarray-8 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-8-element-type (* *))) (deftype pixarray-16 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-16-element-type (* *))) (deftype pixarray-24 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-24-element-type (* *))) (deftype pixarray-32 () '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *))) (deftype pixarray () '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32)) (deftype bitmap () 'pixarray-1) ;;; WITH-UNDERLYING-SIMPLE-VECTOR #+Genera (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (let ((bits-per-element (sys:array-bits-per-element (symbol-value (sys:type-array-element-type element-type))))) `(scl:stack-let ((,variable (make-array (index-ceiling (index* (array-total-size ,pixarray) (sys:array-element-size ,pixarray)) ,bits-per-element) :element-type ',element-type :displaced-to ,pixarray))) (declare (type (vector ,element-type) ,variable)) ,@body))) #+lcl3.0 (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (sys:underlying-simple-vector ,pixarray))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) #+excl (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) `(let ((,variable (cdr (excl::ah_data ,pixarray)))) (declare (type (simple-array ,element-type (*)) ,variable)) ,@body)) #+(or CMU sbcl) ;;; We do *NOT* support viewing an array as having a different element type. ;;; Element-type is ignored. ;;; (defmacro with-underlying-simple-vector ((variable element-type pixarray) &body body) (declare (ignore element-type)) `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data ((,variable ,pixarray) (start) (end)) (declare (ignore start end)) ,@body)) ;;; These are used to read and write pixels from and to CARD8s. ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s. (defmacro read-image-load-byte (size position integer) (unless +image-bit-lsb-first-p+ (setq position (- 7 position))) `(the (unsigned-byte ,size) (#-Genera ldb #+Genera sys:%logldb (byte ,size ,position) (the card8 ,integer)))) ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from ;;; the appropriate number of CARD8s. (defmacro read-image-assemble-bytes (&rest bytes) (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes))) (let ((it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the card8 ,byte) (byte 8 ,(incf count 8)) (the (unsigned-byte ,count) ,it)))) #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it) #+Genera it)) ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit ;;; pixel. (defmacro write-image-load-byte (position integer integer-size) integer-size (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position))) `(the card8 (#-Genera ldb #+Genera sys:%logldb (byte 8 ,position) #-Genera (the (unsigned-byte ,integer-size) ,integer) #+Genera ,integer ))) ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit ;;; pixels. (defmacro write-image-assemble-bytes (&rest bytes) (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes))) (let ((size (floor 8 (length bytes))) (it (first bytes)) (count 0)) (dolist (byte (rest bytes)) (setq it `(#-Genera dpb #+Genera sys:%logdpb (the (unsigned-byte ,size) ,byte) (byte ,size ,(incf count size)) (the (unsigned-byte ,count) ,it)))) `(the card8 ,it))) #+(or Genera lcl3.0 excl) (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+) #+(or Genera lcl3.0 excl) (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 #+(or Genera lcl3.0 excl) (defconstant *image-bit-ordering-table* '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (nil t)) ((2 (15 08) (07 00) (31 24) (23 16)) (nil t)) ((4 (31 24) (23 16) (15 08) (07 00)) (nil t)) ((1 (00 07) (08 15) (16 23) (24 31)) (t nil)) ((2 (08 15) (00 07) (24 31) (16 23)) (t nil)) ((4 (24 31) (16 23) (08 15) (00 07)) (t nil)) ((1 (07 00) (15 08) (23 16) (31 24)) (t t)) ((2 (07 00) (15 08) (23 16) (31 24)) (t t)) ((4 (07 00) (15 08) (23 16) (31 24)) (t t)))) #+(or Genera lcl3.0 excl) (defun compute-image-byte-and-bit-ordering () (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p)) ;; First compute the ordering (let ((ordering nil) (a (make-array '(1 32) :element-type 'bit :initial-element 0))) (dotimes (i 4) (push (flet ((bitpos (a i n) (declare (optimize (speed 3) (safety 0) (space 0))) (declare (type (simple-array bit (* *)) a) (type fixnum i n)) (with-underlying-simple-vector (v (unsigned-byte 8) a) (prog2 (setf (aref v i) n) (dotimes (i 32) (unless (zerop (aref a 0 i)) (return i))) (setf (aref v i) 0))))) (list (bitpos a i #b10000000) (bitpos a i #b00000001))) ordering)) (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering))) ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p (let ((byte-and-bit-ordering (second (assoc ordering *image-bit-ordering-table* :test #'equal)))) (unless byte-and-bit-ordering (error "Couldn't determine image byte and bit ordering~@ measured image ordering = ~A" ordering)) (values-list byte-and-bit-ordering)))) #+(or Genera lcl3.0 excl) (multiple-value-setq (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (compute-image-byte-and-bit-ordering)) ;;; If you can write fast routines that can read and write pixarrays out of a ;;; buffer-bytes, do it! It makes the image code a lot faster. The ;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines ;;; return T if they can do it, NIL if they can't. ;;; FIXME: though we have some #+sbcl -conditionalized routines in ;;; here, they would appear not to work, and so are commented out in ;;; the the FAST-xxx-PIXARRAY routines themseleves. Investigate ;;; whether the unoptimized routines are often used, and also whether ;;; speeding them up while maintaining correctness is possible. ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s #+(or lcl3.0 excl) (defun fast-read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the fixnum (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (the fixnum (- (the fixnum (- width left-bits)) right-bits))) (middle-bytes (index-floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits middle-bytes) (fixnum middle-bits)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x (array-row-major-index array y left-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref vector (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref vector (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref vector (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref vector (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref vector (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref vector (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-bits) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (array-row-major-index array y (index+ left-bits middle-bits)))) (declare (type card8 byte) (type array-index x)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref vector (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref vector (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref vector (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref vector (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref vector (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref vector (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) t) #+(or lcl3.0 excl) (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x))) 2))) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x (array-row-major-index array y left-nibbles) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref vector (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref vector (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y 0) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref vector x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) t) #+lispm (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array dimensions :element-type (array-element-type pixarray) :displaced-to bbuf :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height a x y pixarray 0 0)) t) #+(or CMU sbcl) (defun pixarray-element-size (pixarray) (let ((eltype (array-element-type pixarray))) (cond ((eq eltype 'bit) 1) ((and (consp eltype) (eq (first eltype) 'unsigned-byte)) (second eltype)) (t (error "Invalid pixarray: ~S." pixarray))))) #+CMU ;;; COPY-BIT-RECT -- Internal ;;; ;;; This is the classic BITBLT operation, copying a rectangular subarray ;;; from one array to another (but source and destination must not overlap.) ;;; Widths are specified in bits. Neither array can have a non-zero ;;; displacement. We allow extra random bit-offset to be thrown into the X. ;;; (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (lisp::with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) (lisp::with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) sx (index* sy source-width)) (index+ src-idx source-width)) (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits) dx (index* dy dest-width)) (index+ dest-idx dest-width)) (count height (1- count))) ((zerop count)) (declare (type array-index src-idx dest-idx count)) (kernel:bit-bash-copy sdata src-idx ddata dest-idx width))))) #+sbcl (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) (sb-kernel:with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) (sb-kernel:with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) (assert (and (zerop sstart) (zerop dstart))) (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) sx (index* sy source-width)) (index+ src-idx source-width)) (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) dx (index* dy dest-width)) (index+ dest-idx dest-width)) (count height (1- count))) ((zerop count)) (declare (type array-index src-idx dest-idx count)) (sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width))))) #+(or CMU sbcl) (defun fast-read-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (declare (type (array * 2) pixarray)) #.(declare-buffun) (copy-bit-rect bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y height (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-read-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (x-bits (index* x bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line x-bits)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod x-bits 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod x-bits +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (dst card8 pixarray) (funcall (symbol-function image-swap-function) bbuf dst (index+ boffset (index* y padded-bytes-per-line) (index-floor x-bits 8)) 0 (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line (index-floor pixarray-padded-bits-per-line 8) height image-swap-lsb-first-p))) t)))) (defun fast-read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-read-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-read-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-read-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-read-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-read-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-read-pixarray-24)))) (when function (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))))) ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s #+(or lcl3.0 excl) (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-1-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (array-row-major-index array y (index+ start-x middle-bits)))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref vector (index+ x 0)) (if (index> right-bits 1) (aref vector (index+ x 1)) 0) (if (index> right-bits 2) (aref vector (index+ x 2)) 0) (if (index> right-bits 3) (aref vector (index+ x 3)) 0) (if (index> right-bits 4) (aref vector (index+ x 4)) 0) (if (index> right-bits 5) (aref vector (index+ x 5)) 0) (if (index> right-bits 6) (aref vector (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)) (aref vector (index+ x 2)) (aref vector (index+ x 3)) (aref vector (index+ x 4)) (aref vector (index+ x 5)) (aref vector (index+ x 6)) (aref vector (index+ x 7)))))))) t) #+(or lcl3.0 excl) (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-4-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x (array-row-major-index array y start-x) (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref vector (index+ x 0)) (aref vector (index+ x 1)))))))) t) #+(or Genera lcl3.0 excl CMU sbcl) (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (with-underlying-simple-vector (vector pixarray-24-element-type array) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x (array-row-major-index array y x) (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref vector x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) t) #+lispm (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (#+Genera sys:stack-let* #-Genera let* ((dimensions (list (+ y height) (floor (* padded-bytes-per-line 8) bits-per-pixel))) (a (make-array dimensions :element-type (array-element-type pixarray) :displaced-to bbuf :displaced-index-offset (floor (* boffset 8) bits-per-pixel)))) (sys:bitblt boole-1 width height pixarray x y a 0 0)) t) #+(or CMU sbcl) (defun fast-write-pixarray-using-bitblt (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) #.(declare-buffun) (copy-bit-rect pixarray (index* (array-dimension pixarray 1) bits-per-pixel) x y bbuf (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0 height (index* width bits-per-pixel)) t) #+(or Genera lcl3.0 excl) (defun fast-write-pixarray-with-swap (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel +image-unit+ *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p* unit byte-lsb-first-p bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (with-underlying-simple-vector (src card8 pixarray) (funcall (symbol-function image-swap-function) src bbuf (index-floor pixarray-start-bit-offset 8) boffset (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) padded-bytes-per-line height image-swap-lsb-first-p)) t))))) (defun fast-write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (progn bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (or #+(or Genera lcl3.0 excl) (fast-write-pixarray-with-swap bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (let ((function (or #+lispm (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod padded-bytes-per-line 4)) (zerop (index-mod (* #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1) bits-per-pixel) 32)) #'fast-write-pixarray-using-bitblt) #+(or CMU) (and (index= (pixarray-element-size pixarray) bits-per-pixel) #'fast-write-pixarray-using-bitblt) #+(or lcl3.0 excl) (and (index= bits-per-pixel 1) #'fast-write-pixarray-1) #+(or lcl3.0 excl) (and (index= bits-per-pixel 4) #'fast-write-pixarray-4) #+(or Genera lcl3.0 excl CMU) (and (index= bits-per-pixel 24) #'fast-write-pixarray-24)))) (when function (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel function +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))))) ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another (defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel) (declare (type pixarray pixarray copy) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (progn pixarray copy x y width height bits-per-pixel nil) (or #+(or lispm CMU) (let* ((pixarray-padded-pixels-per-line #+Genera (sys:array-row-span pixarray) #-Genera (array-dimension pixarray 1)) (pixarray-padded-bits-per-line (* pixarray-padded-pixels-per-line bits-per-pixel)) (copy-padded-pixels-per-line #+Genera (sys:array-row-span copy) #-Genera (array-dimension copy 1)) (copy-padded-bits-per-line (* copy-padded-pixels-per-line bits-per-pixel))) #-(or CMU) (when (and (= (sys:array-element-size pixarray) bits-per-pixel) (zerop (index-mod pixarray-padded-bits-per-line 32)) (zerop (index-mod copy-padded-bits-per-line 32))) (sys:bitblt boole-1 width height pixarray x y copy 0 0) t) #+(or CMU) (when (index= (pixarray-element-size pixarray) (pixarray-element-size copy) bits-per-pixel) (copy-bit-rect pixarray pixarray-padded-bits-per-line x y copy copy-padded-bits-per-line 0 0 height (index* width bits-per-pixel)) t)) #+(or lcl3.0 excl) (unless (index= bits-per-pixel 24) (let ((pixarray-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index pixarray 1 0) (array-row-major-index pixarray 0 0)) bits-per-pixel))) (copy-padded-bits-per-line (if (index= height 1) 0 (index* (index- (array-row-major-index copy 1 0) (array-row-major-index copy 0 0)) bits-per-pixel))) (pixarray-start-bit-offset (index* (array-row-major-index pixarray y x) bits-per-pixel))) (declare (type array-index pixarray-padded-bits-per-line copy-padded-bits-per-line pixarray-start-bit-offset)) (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*) (and (index-zerop (index-mod pixarray-padded-bits-per-line 8)) (index-zerop (index-mod copy-padded-bits-per-line 8)) (index-zerop (index-mod pixarray-start-bit-offset 8))) (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+)) (index-zerop (index-mod copy-padded-bits-per-line +image-unit+)) (index-zerop (index-mod pixarray-start-bit-offset +image-unit+)))) (with-underlying-simple-vector (src card8 pixarray) (with-underlying-simple-vector (dst card8 copy) (image-noswap src dst (index-floor pixarray-start-bit-offset 8) 0 (index-ceiling (index* width bits-per-pixel) 8) (index-floor pixarray-padded-bits-per-line 8) (index-floor copy-padded-bits-per-line 8) height nil))) t))) #+(or lcl3.0 excl) (macrolet ((copy (type element-type) `(let ((pixarray pixarray) (copy copy)) (declare (type ,type pixarray copy)) #.(declare-buffun) (with-underlying-simple-vector (src ,element-type pixarray) (with-underlying-simple-vector (dst ,element-type copy) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-idx (array-row-major-index copy dst-y 0) (index1+ dst-idx)) (dst-end (index+ dst-idx width)) (src-idx (array-row-major-index pixarray src-y x) (index1+ src-idx))) ((index>= dst-idx dst-end)) (declare (type array-index dst-idx src-idx dst-end)) (setf (aref dst dst-idx) (the ,element-type (aref src src-idx)))))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))) t))) cmucl-21a/src/clx/display.lisp000066400000000000000000000701071260377556400165010ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: display.lisp,v 1.16 2010/11/16 19:13:55 rtoy Exp $") (in-package :xlib) ;;; Authorizaton (defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1")) ;;; X11 Authorization: to prevent malicious users from snooping on a ;;; display, X servers may require connection requests to be ;;; authorized. The X server (or display manager) will create a random ;;; key on startup, and store it as an entry in a file generally named ;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME ;;; function). Clients must extract from this file the "magic cookie" ;;; that corresponds to the server they wish to connect to, and send ;;; it as authorization data when opening the display. ;;; The format of the .Xauthority file is documented in the XFree ;;; sources, in the file xc/lib/Xau/README. ;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and ;;; Scott Fahlman. (defun read-xauth-entry (stream) (labels ((read-short (stream &optional (eof-errorp t)) (let ((high-byte (read-byte stream eof-errorp))) (and high-byte (dpb high-byte (byte 8 8) (read-byte stream))))) (read-short-length-string (stream) (let ((length (read-short stream))) (let ((string (make-string length))) (dotimes (k length) (setf (schar string k) (card8->char (read-byte stream)))) string))) (read-short-length-vector (stream) (let ((length (read-short stream))) (let ((vector (make-array length :element-type '(unsigned-byte 8)))) (dotimes (k length) (setf (aref vector k) (read-byte stream))) vector)))) (let ((family-id (read-short stream nil))) (if (null family-id) (list nil nil nil nil nil) (let* ((address-data (read-short-length-vector stream)) (number (parse-integer (read-short-length-string stream))) (name (read-short-length-string stream)) (data (read-short-length-vector stream)) (family (car (rassoc family-id *protocol-families*)))) (unless family (return-from read-xauth-entry ;; we return FAMILY-ID to signal to ;; GET-BEST-AUTHORIZATION that we haven't finished ;; with the stream. (list family-id nil nil nil nil))) (let ((address (case family (:local (map 'string #'code-char address-data)) (:internet (coerce address-data 'list)) ;; FIXME: we can probably afford not to support ;; :DECNET or :CHAOSNET in this modern age, but ;; :INTERNET6 probably deserve support. -- CSR, ;; 2005-08-07 (t nil)))) ;; if ADDRESS is NIL by this time, we will never match ;; the address of DISPLAY. (list family address number name data))))))) (defun get-best-authorization (host display protocol) ;; parse .Xauthority, extract the cookie for DISPLAY on HOST. ;; PROTOCOL determines whether the server connection is using an ;; Internet protocol (value of :internet) or a non-network ;; protocol such as Unix domain sockets (value of :local). Returns ;; two strings: an authorization name (very likely the string ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as ;; fixnums in a vector. If we fail to find an appropriate cookie, ;; return two empty strings. (let ((pathname (authority-pathname))) (when pathname (with-open-file (stream pathname :element-type '(unsigned-byte 8) :if-does-not-exist nil) (when stream (let* ((host-address (and (eql protocol :internet) (rest (host-address host protocol)))) (best-name nil) (best-pos nil) (best-data nil)) ;; Check for the localhost address, in which case we're ;; really FamilyLocal. (when (or (eql protocol :local) (and (eql protocol :internet) (equal host-address '(127 0 0 1)))) (setq host-address (get-host-name)) (setq protocol :local)) (loop (destructuring-bind (family address number name data) (read-xauth-entry stream) (unless family (return)) (when (and (eql family protocol) (or (equal host-address address) (and (eql family :local) (equal address "localhost"))) (= number display) (let ((pos1 (position name *known-authorizations* :test #'string=))) (and pos1 (or (null best-pos) (< pos1 best-pos))))) (setf best-name name best-pos (position name *known-authorizations* :test #'string=) best-data data)))) (when best-name (return-from get-best-authorization (values best-name best-data))))))) (values "" ""))) (defmacro with-display ((display &key timeout inline) &body body) ;; This macro is for use in a multi-process environment. It ;; provides exclusive access to the local display object for ;; multiple request generation. It need not provide immediate ;; exclusive access for replies; that is, if another process is ;; waiting for a reply (while not in a with-display), then ;; synchronization need not (but can) occur immediately. Except ;; where noted, all routines effectively contain an implicit ;; with-display where needed, so that correct synchronization is ;; always provided at the interface level on a per-call basis. ;; Nested uses of this macro will work correctly. This macro does ;; not prevent concurrent event processing; see with-event-queue. `(with-buffer (,display ,@(and timeout `(:timeout ,timeout)) ,@(and inline `(:inline ,inline))) ,@body)) ;; ;; Resource id management ;; (defun initialize-resource-allocator (display) ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask (let ((id-mask (display-resource-id-mask display))) (unless (zerop id-mask) ;; zero mask is an error (do ((first 0 (index1+ first)) (mask id-mask (the mask32 (ash mask -1)))) ((oddp mask) (setf (display-resource-id-byte display) (byte (integer-length mask) first))) (declare (type array-index first) (type mask32 mask)))))) (defun resourcealloc (display) ;; Allocate a resource-id for use in DISPLAY (declare (type display display)) (declare (clx-values resource-id)) (loop for next-count upfrom (1+ (display-resource-id-count display)) repeat (1+ (display-resource-id-mask display)) as id = (dpb next-count (display-resource-id-byte display) (display-resource-id-base display)) unless (nth-value 1 (gethash id (display-resource-id-map display))) do (setf (display-resource-id-count display) next-count) (setf (gethash id (display-resource-id-map display)) t) (return-from resourcealloc id)) ;; internal consistency check (assert (= (hash-table-count (display-resource-id-map display)) (1+ (display-resource-id-mask display)))) ;; tell the user what's gone wrong (error 'resource-ids-exhausted)) (defmacro allocate-resource-id (display object type) ;; Allocate a resource-id for OBJECT in DISPLAY `(with-display (,display) ,(if (member (eval type) +clx-cached-types+) `(let ((id (funcall (display-xid ,display) ,display))) (save-id ,display id ,object) id) `(funcall (display-xid ,display) ,display)))) (defmacro deallocate-resource-id (display id type) (declare (ignore type)) ;; Deallocate a resource-id for OBJECT in DISPLAY `(deallocate-resource-id-internal ,display ,id)) (defun deallocate-resource-id-internal (display id) (with-display (display) (remhash id (display-resource-id-map display)))) (defun lookup-resource-id (display id) ;; Find the object associated with resource ID (gethash id (display-resource-id-map display))) (defun save-id (display id object) ;; cache the object associated with ID for this display. (declare (type display display) (type integer id) (type t object)) (declare (clx-values object)) ;; we can't cache objects from other clients, because they may ;; become invalid without us being told about that. (let ((base (display-resource-id-base display)) (mask (display-resource-id-mask display))) (when (= (logandc2 id mask) base) (setf (gethash id (display-resource-id-map display)) object)) object)) ;; Define functions to find the CLX data types given a display and resource-id ;; If the data type is being cached, look there first. (macrolet ((generate-lookup-functions (useless-name &body types) `(within-definition (,useless-name generate-lookup-functions) ,@(mapcar #'(lambda (type) `(defun ,(xintern 'lookup- type) (display id) (declare (type display display) (type resource-id id)) (declare (clx-values ,type)) ,(if (member type +clx-cached-types+) `(let ((,type (lookup-resource-id display id))) (cond ((null ,type) ;; Not found, create and save it. (setq ,type (,(xintern 'make- type) :display display :id id)) (save-id display id ,type)) ;; Found. Check the type ,(cond ((null +type-check?+) `(t ,type)) ((member type '(window pixmap)) `((type? ,type 'drawable) ,type)) (t `((type? ,type ',type) ,type))) ,@(when +type-check?+ `((t (x-error 'lookup-error :id id :display display :type ',type :object ,type)))))) ;; Not being cached. Create a new one each time. `(,(xintern 'make- type) :display display :id id)))) types)))) (generate-lookup-functions ignore drawable window pixmap gcontext cursor colormap font)) (defun id-atom (id display) ;; Return the cached atom for an atom ID (declare (type resource-id id) (type display display)) (declare (clx-values (or null keyword))) (gethash id (display-atom-id-map display))) (defun atom-id (atom display) ;; Return the ID for an atom in DISPLAY (declare (type xatom atom) (type display display)) (declare (clx-values (or null resource-id))) (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom)) (display-atom-cache display))) (defun set-atom-id (atom display id) ;; Set the ID for an atom in DISPLAY (declare (type xatom atom) (type display display) (type resource-id id)) (declare (clx-values resource-id)) (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom)))) (setf (gethash id (display-atom-id-map display)) atom) (setf (gethash atom (display-atom-cache display)) id) id)) (defsetf atom-id set-atom-id) (defun initialize-predefined-atoms (display) (dotimes (i (length +predefined-atoms+)) (declare (type resource-id i)) (setf (atom-id (svref +predefined-atoms+ i) display) i))) (defun visual-info (display visual-id) (declare (type display display) (type resource-id visual-id) (clx-values visual-info)) (when (zerop visual-id) (return-from visual-info nil)) (dolist (screen (display-roots display)) (declare (type screen screen)) (dolist (depth (screen-depths screen)) (declare (type cons depth)) (dolist (visual-info (rest depth)) (declare (type visual-info visual-info)) (when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info)) (return-from visual-info visual-info))))) (error "Visual info not found for id #x~x in display ~s." visual-id display)) ;; ;; Display functions ;; (defmacro with-event-queue ((display &key timeout inline) &body body &environment env) ;; exclusive access to event queue `(macrolet ((with-event-queue ((display &key timeout) &body body) ;; Speedup hack for lexically nested with-event-queues `(progn (progn ,display ,@(and timeout `(,timeout)) nil) ,@body))) ,(if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.with-event-queue-body. () ,@body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.with-event-queue-body.)) (with-event-queue-function ,display ,timeout #'.with-event-queue-body.)) (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(let (,@(unless (eq disp display) `((,disp ,display)))) (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))))) (defun with-event-queue-function (display timeout function) (declare (type display display) (type (or null number) timeout) (type function function) #+clx-ansi-common-lisp (dynamic-extent function) ;; FIXME: see SBCL bug #243 (ignorable display timeout) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (with-event-queue (display :timeout timeout :inline t) (funcall function))) (defmacro with-event-queue-internal ((display &key timeout) &body body) ;; exclusive access to the internal event queues (let ((disp (if (or (symbolp display) (constantp display)) display '.display.))) `(let (,@(unless (eq disp display) `((,disp ,display)))) (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock" ,@(and timeout `(:timeout ,timeout))) ,@body)))) (defun open-default-display (&optional display-name) "Open a connection to DISPLAY-NAME if supplied, or to the appropriate default display as given by GET-DEFAULT-DISPLAY otherwise. OPEN-DISPLAY-NAME always attempts to do display authorization. The hostname is resolved to an address, then authorization data for the (protocol, host-address, displaynumber) triple is looked up in the file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority). If the protocol is :local, or if the hostname resolves to the local host, authority data for the local machine's actual hostname - as returned by gethostname(3) - is used instead." (destructuring-bind (host display screen protocol) (get-default-display display-name) (let ((display (open-display host :display display :protocol protocol))) (setf (display-default-screen display) (nth screen (display-roots display))) display))) (defun open-display (host &key (display 0) protocol authorization-name authorization-data) ;; Implementation specific routine to setup the buffer for a ;; specific host and display. This must interface with the local ;; network facilities, and will probably do special things to ;; circumvent the nework when displaying on the local host. ;; ;; A string must be acceptable as a host, but otherwise the possible types ;; for host and protocol are not constrained, and will likely be very ;; system dependent. The default protocol is system specific. Authorization, ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) (let ((protocol (if (member host '("" "unix") :test #'equal) :local protocol))) ;; Get the authorization mechanism from the environment. Handle the ;; special case of a host name of "" and "unix" which means the ;; protocol is :local (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) (get-best-authorization host display protocol))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) (disp (make-buffer *output-buffer-size* #'make-display-internal :host host :display display :output-stream stream :input-stream stream)) (ok-p nil)) (unwind-protect (progn (display-connect disp :authorization-name authorization-name :authorization-data authorization-data) (setf (display-authorization-name disp) authorization-name) (setf (display-authorization-data disp) authorization-data) (initialize-resource-allocator disp) (initialize-predefined-atoms disp) (initialize-extensions disp) (when (assoc "BIG-REQUESTS" (display-extension-alist disp) :test #'string=) (enable-big-requests disp)) (setq ok-p t)) (unless ok-p (close-display disp :abort t))) disp))) (defun display-force-output (display) ; Output is normally buffered, this forces any buffered output to the server. (declare (type display display)) (with-display (display) (buffer-force-output display))) (defun close-display (display &key abort) ;; Close the host connection in DISPLAY (declare (type display display)) (close-buffer display :abort abort)) (defun display-connect (display &key authorization-name authorization-data) (with-buffer-output (display :sizes (8 16)) (card8-put 0 (ecase (display-byte-order display) (:lsbfirst #x6c) ;; Ascii lowercase l - Least Significant Byte First (:msbfirst #x42))) ;; Ascii uppercase B - Most Significant Byte First (card16-put 2 *protocol-major-version*) (card16-put 4 *protocol-minor-version*) (card16-put 6 (length authorization-name)) (card16-put 8 (length authorization-data)) (write-sequence-char display 12 authorization-name) (if (stringp authorization-data) (write-sequence-char display (lround (+ 12 (length authorization-name))) authorization-data) (write-sequence-card8 display (lround (+ 12 (length authorization-name))) authorization-data))) (buffer-force-output display) (let ((reply-buffer nil)) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect (progn (setq reply-buffer (allocate-reply-buffer #x1000)) (with-buffer-input (reply-buffer :sizes (8 16 32)) (buffer-input display buffer-bbuf 0 8) (let ((success (boolean-get 0)) (reason-length (card8-get 1)) (major-version (card16-get 2)) (minor-version (card16-get 4)) (total-length (card16-get 6)) vendor-length num-roots num-formats) (declare (ignore total-length)) (unless success (x-error 'connection-failure :major-version major-version :minor-version minor-version :host (display-host display) :display (display-display display) :reason (progn (buffer-input display buffer-bbuf 0 reason-length) (string-get reason-length 0 :reply-buffer reply-buffer)))) (buffer-input display buffer-bbuf 0 32) (setf (display-protocol-major-version display) major-version) (setf (display-protocol-minor-version display) minor-version) (setf (display-release-number display) (card32-get 0)) (setf (display-resource-id-base display) (card32-get 4)) (setf (display-resource-id-mask display) (card32-get 8)) (setf (display-motion-buffer-size display) (card32-get 12)) (setq vendor-length (card16-get 16)) (setf (display-max-request-length display) (card16-get 18)) (setq num-roots (card8-get 20)) (setq num-formats (card8-get 21)) ;; Get the image-info (setf (display-image-lsb-first-p display) (zerop (card8-get 22))) (let ((format (display-bitmap-format display))) (declare (type bitmap-format format)) (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23))) (setf (bitmap-format-unit format) (card8-get 24)) (setf (bitmap-format-pad format) (card8-get 25))) (setf (display-min-keycode display) (card8-get 26)) (setf (display-max-keycode display) (card8-get 27)) ;; 4 bytes unused ;; Get the vendor string (buffer-input display buffer-bbuf 0 (lround vendor-length)) (setf (display-vendor-name display) (string-get vendor-length 0 :reply-buffer reply-buffer)) ;; Initialize the pixmap formats (dotimes (i num-formats) ;; loop gathering pixmap formats (declare (ignorable i)) (buffer-input display buffer-bbuf 0 8) (push (make-pixmap-format :depth (card8-get 0) :bits-per-pixel (card8-get 1) :scanline-pad (card8-get 2)) ; 5 unused bytes (display-pixmap-formats display))) (setf (display-pixmap-formats display) (nreverse (display-pixmap-formats display))) ;; Initialize the screens (dotimes (i num-roots) (declare (ignorable i)) (buffer-input display buffer-bbuf 0 40) (let* ((root-id (card32-get 0)) (root (make-window :id root-id :display display)) (root-visual (card32-get 32)) (default-colormap-id (card32-get 4)) (default-colormap (make-colormap :id default-colormap-id :display display)) (screen (make-screen :root root :default-colormap default-colormap :white-pixel (card32-get 8) :black-pixel (card32-get 12) :event-mask-at-open (card32-get 16) :width (card16-get 20) :height (card16-get 22) :width-in-millimeters (card16-get 24) :height-in-millimeters (card16-get 26) :min-installed-maps (card16-get 28) :max-installed-maps (card16-get 30) :backing-stores (member8-get 36 :never :when-mapped :always) :save-unders-p (boolean-get 37) :root-depth (card8-get 38))) (num-depths (card8-get 39)) (depths nil)) ;; Save root window for event reporting (save-id display root-id root) (save-id display default-colormap-id default-colormap) ;; Create the depth AList for a screen, (depth . visual-infos) (dotimes (j num-depths) (declare (ignorable j)) (buffer-input display buffer-bbuf 0 8) (let ((depth (card8-get 0)) (num-visuals (card16-get 2)) (visuals nil)) ;; 4 bytes unused (dotimes (k num-visuals) (declare (ignorable k)) (buffer-input display buffer-bbuf 0 24) (let* ((visual (card32-get 0)) (visual-info (make-visual-info :id visual :display display :class (member8-get 4 :static-gray :gray-scale :static-color :pseudo-color :true-color :direct-color) :bits-per-rgb (card8-get 5) :colormap-entries (card16-get 6) :red-mask (card32-get 8) :green-mask (card32-get 12) :blue-mask (card32-get 16) ;; 4 bytes unused ))) (push visual-info visuals) (when (funcall (resource-id-map-test) root-visual visual) (setf (screen-root-visual-info screen) (setf (colormap-visual-info default-colormap) visual-info))))) (push (cons depth (nreverse visuals)) depths))) (setf (screen-depths screen) (nreverse depths)) (push screen (display-roots display)))) (setf (display-roots display) (nreverse (display-roots display))) (setf (display-default-screen display) (first (display-roots display)))))) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) display) (defun display-protocol-version (display) (declare (type display display)) (declare (clx-values major minor)) (values (display-protocol-major-version display) (display-protocol-minor-version display))) (defun display-vendor (display) (declare (type display display)) (declare (clx-values name release)) (values (display-vendor-name display) (display-release-number display))) (defun display-nscreens (display) (declare (type display display)) (length (display-roots display))) #+comment ;; defined by the DISPLAY defstruct (defsetf display-error-handler (display) (handler) ;; All errors (synchronous and asynchronous) are processed by ;; calling an error handler in the display. If handler is a ;; sequence it is expected to contain handler functions specific to ;; each error; the error code is used to index the sequence, ;; fetching the appropriate handler. Any results returned by the ;; handler are ignored; it is assumed the handler either takes care ;; of the error completely, or else signals. For all core errors, ;; the keyword/value argument pairs are: ;; :display display ;; :error-key error-key ;; :major integer ;; :minor integer ;; :sequence integer ;; :current-sequence integer ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and ;; :window errors another pair is: ;; :resource-id integer ;; For :atom errors, another pair is: ;; :atom-id integer ;; For :value errors, another pair is: ;; :value integer ) ;; setf'able ;; If defined, called after every protocol request is generated, ;; even those inside explicit with-display's, but never called from ;; inside the after-function itself. The function is called inside ;; the effective with-display for the associated request. Default ;; value is nil. Can be set, for example, to #'display-force-output ;; or #'display-finish-output. (defvar *inside-display-after-function* nil) (defun display-invoke-after-function (display) ; Called after every protocal request is generated (declare (type display display)) (when (and (display-after-function display) (not *inside-display-after-function*)) (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls (funcall (display-after-function display) display)))) (defun display-finish-output (display) ;; Forces output, then causes a round-trip to ensure that all possible ;; errors and events have been received. (declare (type display display)) (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) () ) ;; Report asynchronous errors here if the user wants us to. (report-asynchronous-errors display :after-finish-output)) (defparameter *request-names* '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes" "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow" "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows" "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree" "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty" "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner" "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer" "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard" "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents" "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents" "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus" "QueryKeymap" "OpenFont" "CloseFont" "QueryFont" "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath" "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC" "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles" "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane" "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle" "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc" "PutImage" "GetImage" "PolyText8" "PolyText16" "ImageText8" "ImageText16" "CreateColormap" "FreeColormap" "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps" "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes" "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors" "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor" "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions" "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl" "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver" "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl" "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver" "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping")) cmucl-21a/src/clx/doc.lisp000066400000000000000000004227411260377556400156060ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and ;;; Texas Instruments Incorporated ;;; Permission to use, copy, modify, and distribute this document for any purpose ;;; and without fee is hereby granted, provided that the above copyright notice ;;; appear in all copies and that both that copyright notice and this permission ;;; notice are retained, and that the name of M.I.T. not be used in advertising or ;;; publicity pertaining to this document without specific, written prior ;;; permission. M.I.T. makes no representations about the suitability of this ;;; document or the protocol defined in this document for any purpose. It is ;;; provided "as is" without express or implied warranty. ;;; Texas Instruments Incorporated provides this document "as is" without ;;; express or implied warranty. #+cmu (ext:file-comment "$Header: src/clx/doc.lisp $") ;; Version 4 ;; This is considered a somewhat changeable interface. Discussion of better ;; integration with CLOS, support for user-specified subclassess of basic ;; objects, and the additional functionality to match the C Xlib is still in ;; progress. ;; Primary Interface Author: ;; Robert W. Scheifler ;; MIT Laboratory for Computer Science ;; 545 Technology Square, Room 418 ;; Cambridge, MA 02139 ;; rws@zermatt.lcs.mit.edu ;; Design Contributors: ;; Dan Cerys, Texas Instruments ;; Scott Fahlman, CMU ;; Charles Hornig, Symbolics ;; John Irwin, Franz ;; Kerry Kimbrough, Texas Instruments ;; Chris Lindblad, MIT ;; Rob MacLachlan, CMU ;; Mike McMahon, Symbolics ;; David Moon, Symbolics ;; LaMott Oren, Texas Instruments ;; Daniel Weinreb, Symbolics ;; John Wroclawski, MIT ;; Richard Zippel, Symbolics ;; CLX Extensions ;; Adds some of the functionality provided by the C XLIB library. ;; ;; Primary Author ;; LaMott G. Oren ;; Texas Instruments ;; ;; Design Contributors: ;; Robert W. Scheifler, MIT ;; Note: all of the following is in the package XLIB. (declaim (declaration arglist clx-values)) ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of ;; the relationships should be fairly obvious. We have no intention of writing yet ;; another moby document for this interface. (deftype card32 () '(unsigned-byte 32)) (deftype card29 () '(unsigned-byte 29)) (deftype int32 () '(signed-byte 32)) (deftype card16 () '(unsigned-byte 16)) (deftype int16 () '(signed-byte 16)) (deftype card8 () '(unsigned-byte 8)) (deftype int8 () '(signed-byte 8)) (deftype mask32 () 'card32) (deftype mask16 () 'card16) (deftype resource-id () 'card29) ;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color. ;; These types are defined solely by a functional interface; we do not specify ;; whether they are implemented as structures or flavors or ... Although functions ;; below are written using DEFUN, this is not an implementation requirement (although ;; it is a requirement that they be functions as opposed to macros or special forms). ;; It is unclear whether with-slots in the Common Lisp Object System must work on ;; them. ;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as ;; compound objects, rather than as integer resource-ids. This allows applications ;; to deal with multiple displays without having an explicit display argument in the ;; most common functions. Every function uses the display object indicated by the ;; first argument that is or contains a display; it is an error if arguments contain ;; different displays, and predictable results are not guaranteed. ;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the ;; following five functions: (defun -display () (declare (type ) (clx-values display))) (defun -id () (declare (type ) (clx-values resource-id))) (defun -equal (-1 -2) (declare (type -1 -2))) (defun -p () (declare (type ) (clx-values boolean))) ;; The following functions are provided by color objects: ;; The intention is that IHS and YIQ and CYM interfaces will also exist. Note that ;; we are explicitly using a different spectrum representation than what is actually ;; transmitted in the protocol. (deftype rgb-val () '(real 0 1)) (defun make-color (&key red green blue &allow-other-keys) ; for expansion (declare (type rgb-val red green blue) (clx-values color))) (defun color-rgb (color) (declare (type color color) (clx-values red green blue))) (defun color-red (color) ;; setf'able (declare (type color color) (clx-values rgb-val))) (defun color-green (color) ;; setf'able (declare (type color color) (clx-values rgb-val))) (defun color-blue (color) ;; setf'able (declare (type color color) (clx-values rgb-val))) (deftype drawable () '(or window pixmap)) ;; Atoms are accepted as strings or symbols, and are always returned as keywords. ;; Protocol-level integer atom ids are hidden, using a cache in the display object. (deftype xatom () '(or string symbol)) (deftype stringable () '(or string symbol)) (deftype fontable () '(or stringable font)) ;; Nil stands for CurrentTime. (deftype timestamp () '(or null card32)) (deftype bit-gravity () '(member :forget :static :north-west :north :north-east :west :center :east :south-west :south :south-east)) (deftype win-gravity () '(member :unmap :static :north-west :north :north-east :west :center :east :south-west :south :south-east)) (deftype grab-status () '(member :success :already-grabbed :frozen :invalid-time :not-viewable)) (deftype boolean () '(or null (not null))) (deftype pixel () '(unsigned-byte 32)) (deftype image-depth () '(integer 0 32)) (deftype keysym () 'card32) (deftype array-index () `(integer 0 ,array-dimension-limit)) ;; An association list. (deftype alist (key-type-and-name datum-type-and-name) 'list) (deftype clx-list (&optional element-type) 'list) (deftype clx-sequence (&optional element-type) 'sequence) ;; A sequence, containing zero or more repetitions of the given elements, ;; with the elements expressed as (type name). (deftype repeat-seq (&rest elts) 'sequence) (deftype point-seq () '(repeat-seq (int16 x) (int16 y))) (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2))) (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height))) ;; Note that we are explicitly using a different angle representation than what ;; is actually transmitted in the protocol. (deftype angle () '(real #.(* -2 pi) #.(* 2 pi))) (deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height) (angle angle1) (angle angle2))) (deftype event-mask-class () '(member :key-press :key-release :owner-grab-button :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :exposure :visibility-change :structure-notify :resize-redirect :substructure-notify :substructure-redirect :focus-change :property-change :colormap-change :keymap-state)) (deftype event-mask () '(or mask32 (clx-list event-mask-class))) (deftype pointer-event-mask-class () '(member :button-press :button-release :enter-window :leave-window :pointer-motion :pointer-motion-hint :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion :keymap-state)) (deftype pointer-event-mask () '(or mask32 (clx-list pointer-event-mask-class))) (deftype device-event-mask-class () '(member :key-press :key-release :button-press :button-release :pointer-motion :button-1-motion :button-2-motion :button-3-motion :button-4-motion :button-5-motion :button-motion)) (deftype device-event-mask () '(or mask32 (clx-list device-event-mask-class))) (deftype modifier-key () '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5)) (deftype modifier-mask () '(or (member :any) mask16 (clx-list modifier-key))) (deftype state-mask-key () '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5))) (deftype gcontext-key () '(member :function :plane-mask :foreground :background :line-width :line-style :cap-style :join-style :fill-style :fill-rule :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes)) (deftype event-key () '(member :key-press :key-release :button-press :button-release :motion-notify :enter-notify :leave-notify :focus-in :focus-out :keymap-notify :exposure :graphics-exposure :no-exposure :visibility-notify :create-notify :destroy-notify :unmap-notify :map-notify :map-request :reparent-notify :configure-notify :gravity-notify :resize-request :configure-request :circulate-notify :circulate-request :property-notify :selection-clear :selection-request :selection-notify :colormap-notify :client-message)) (deftype error-key () '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice :illegal-request :implementation :length :match :name :pixmap :value :window)) (deftype draw-direction () '(member :left-to-right :right-to-left)) (defstruct bitmap-format (unit :type (member 8 16 32)) (pad :type (member 8 16 32)) (lsb-first-p :type boolean)) (defstruct pixmap-format (depth :type image-depth) (bits-per-pixel :type (member 1 4 8 16 24 32)) (pad :type (member 8 16 32))) (defstruct visual-info (id :type resource-id) (display :type display) (class :type (member :static-gray :static-color :true-color :gray-scale :pseudo-color :direct-color)) (red-mask :type pixel) (green-mask :type pixel) (blue-mask :type pixel) (bits-per-rgb :type card8) (colormap-entries :type card16)) (defstruct screen (root :type window) (width :type card16) (height :type card16) (width-in-millimeters :type card16) (height-in-millimeters :type card16) (depths :type (alist (image-depth depth) ((clx-list visual-info) visuals))) (root-depth :type image-depth) (root-visual-info :type visual-info) (default-colormap :type colormap) (white-pixel :type pixel) (black-pixel :type pixel) (min-installed-maps :type card16) (max-installed-maps :type card16) (backing-stores :type (member :never :when-mapped :always)) (save-unders-p :type boolean) (event-mask-at-open :type mask32)) (defun screen-root-visual (screen) (declare (type screen screen) (clx-values resource-id))) ;; The list contains alternating keywords and integers. (deftype font-props () 'list) (defun open-display (host &key (display 0) protocol) ;; A string must be acceptable as a host, but otherwise the possible types for host ;; and protocol are not constrained, and will likely be very system dependent. The ;; default protocol is system specific. Authorization, if any, is assumed to come ;; from the environment somehow. (declare (type integer display) (clx-values display))) (defun display-protocol-major-version (display) (declare (type display display) (clx-values card16))) (defun display-protocol-minor-version (display) (declare (type display display) (clx-values card16))) (defun display-vendor-name (display) (declare (type display display) (clx-values string))) (defun display-release-number (display) (declare (type display display) (clx-values card32))) (defun display-image-lsb-first-p (display) (declare (type display display) (clx-values boolean))) (defun display-bitmap-formap (display) (declare (type display display) (clx-values bitmap-format))) (defun display-pixmap-formats (display) (declare (type display display) (clx-values (clx-list pixmap-formats)))) (defun display-roots (display) (declare (type display display) (clx-values (clx-list screen)))) (defun display-motion-buffer-size (display) (declare (type display display) (clx-values card32))) (defun display-max-request-length (display) (declare (type display display) (clx-values card16))) (defun display-min-keycode (display) (declare (type display display) (clx-values card8))) (defun display-max-keycode (display) (declare (type display display) (clx-values card8))) (defun close-display (display) (declare (type display display))) (defun display-error-handler (display) (declare (type display display) (clx-values handler))) (defsetf display-error-handler (display) (handler) ;; All errors (synchronous and asynchronous) are processed by calling an error ;; handler in the display. If handler is a sequence it is expected to contain ;; handler functions specific to each error; the error code is used to index the ;; sequence, fetching the appropriate handler. Any results returned by the handler ;; are ignored; it is assumed the handler either takes care of the error ;; completely, or else signals. For all core errors, the keyword/value argument ;; pairs are: ;; :major card8 ;; :minor card16 ;; :sequence card16 ;; :current-sequence card16 ;; :asynchronous (member t nil) ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and ;; :window errors another pair is: ;; :resource-id card32 ;; For :atom errors, another pair is: ;; :atom-id card32 ;; For :value errors, another pair is: ;; :value card32 (declare (type display display) (type (or (clx-sequence (function (display symbol &key &allow-other-keys))) (function (display symbol &key &allow-other-keys))) handler))) (defsetf display-report-asynchronous-errors (display) (when) ;; Most useful in multi-process lisps. ;; ;; Synchronous errors are always signalled in the process that made the ;; synchronous request. An error is considered synchronous if a process is ;; waiting for a reply with the same request-id as the error. ;; ;; Asynchronous errors can be signalled at any one of these three times: ;; ;; 1. As soon as they are read. They get signalled in whichever process ;; was doing the reading. This is enabled by ;; (setf (xlib:display-report-asynchronous-errors display) ;; '(:immediately)) ;; This is the default. ;; ;; 2. Before any events are to be handled. You get these by doing an ;; event-listen with any timeout value other than 0, or in of the event ;; processing forms. This is useful if you using a background process to ;; handle input. This is enabled by ;; (setf (xlib:display-report-asynchronous-errors display) ;; '(:before-event-handling)) ;; ;; 3. After a display-finish-output. You get these by doing a ;; display-finish-output. A cliche using this might have a with-display ;; wrapped around the display operations that possibly cause an asynchronous ;; error, with a display-finish-output right the end of the with-display to ;; catch any asynchronous errors. This is enabled by ;; (setf (xlib:display-report-asynchronous-errors display) ;; '(:after-finish-output)) ;; ;; You can select any combination of the three keywords. For example, to ;; get errors reported before event handling and after finish-output, ;; (setf (xlib:display-report-asynchronous-errors display) ;; '(:before-event-handling :after-finish-output)) (declare (type list when)) ) (defmacro define-condition (name base &body items) ;; just a place-holder here for the real thing ) (define-condition request-error error display major minor sequence current-sequence asynchronous) (defun default-error-handler (display error-key &key &allow-other-keys) ;; The default display-error-handler. ;; It signals the conditions listed below. (declare (type display display) (type symbol error-key)) ) (define-condition resource-error request-error resource-id) (define-condition access-error request-error) (define-condition alloc-error request-error) (define-condition atom-error request-error atom-id) (define-condition colormap-error resource-error) (define-condition cursor-error resource-error) (define-condition drawable-error resource-error) (define-condition font-error resource-error) (define-condition gcontext-error resource-error) (define-condition id-choice-error resource-error) (define-condition illegal-request-error request-error) (define-condition implementation-error request-error) (define-condition length-error request-error) (define-condition match-error request-error) (define-condition name-error request-error) (define-condition pixmap-error resource-error) (define-condition value-error request-error value) (define-condition window-error resource-error) (defmacro with-display ((display) &body body) ;; This macro is for use in a multi-process environment. It provides exclusive ;; access to the local display object for multiple request generation. It need not ;; provide immediate exclusive access for replies; that is, if another process is ;; waiting for a reply (while not in a with-display), then synchronization need not ;; (but can) occur immediately. Except where noted, all routines effectively ;; contain an implicit with-display where needed, so that correct synchronization ;; is always provided at the interface level on a per-call basis. Nested uses of ;; this macro will work correctly. This macro does not prevent concurrent event ;; processing; see with-event-queue. ) (defun display-force-output (display) ;; Output is normally buffered; this forces any buffered output. (declare (type display display))) (defun display-finish-output (display) ;; Forces output, then causes a round-trip to ensure that all possible errors and ;; events have been received. (declare (type display display))) (defun display-after-function (display) ;; setf'able ;; If defined, called after every protocol request is generated, even those inside ;; explicit with-display's, but never called from inside the after-function itself. ;; The function is called inside the effective with-display for the associated ;; request. Default value is nil. Can be set, for example, to ;; #'display-force-output or #'display-finish-output. (declare (type display display) (clx-values (or null (function (display)))))) (defun create-window (&key parent x y width height (depth 0) (border-width 0) (class :copy) (visual :copy) background border gravity bit-gravity backing-store backing-planes backing-pixel save-under event-mask do-not-propagate-mask override-redirect colormap cursor) ;; Display is obtained from parent. Only non-nil attributes are passed on in the ;; request: the function makes no assumptions about what the actual protocol ;; defaults are. Width and height are the inside size, excluding border. (declare (type window parent) (type int16 x y) (type card16 width height depth border-width) (type (member :copy :input-output :input-only) class) (type (or (member :copy) visual-info) visual) (type (or null (member :none :parent-relative) pixel pixmap) background) (type (or null (member :copy) pixel pixmap) border) (type (or null win-gravity) gravity) (type (or null bit-gravity) bit-gravity) (type (or null (member :not-useful :when-mapped :always) backing-store)) (type (or null pixel) backing-planes backing-pixel) (type (or null event-mask) event-mask) (type (or null device-event-mask) do-not-propagate-mask) (type (or null (member :on :off)) save-under override-redirect) (type (or null (member :copy) colormap) colormap) (type (or null (member :none) cursor) cursor) (clx-values window))) (defun window-class (window) (declare (type window window) (clx-values (member :input-output :input-only)))) (defun window-visual-info (window) (declare (type window window) (clx-values visual-info))) (defun window-visual (window) (declare (type window window) (clx-values resource-id))) (defsetf window-background (window) (background) (declare (type window window) (type (or (member :none :parent-relative) pixel pixmap) background))) (defsetf window-border (window) (border) (declare (type window window) (type (or (member :copy) pixel pixmap) border))) (defun window-gravity (window) ;; setf'able (declare (type window window) (clx-values win-gravity))) (defun window-bit-gravity (window) ;; setf'able (declare (type window window) (clx-values bit-gravity))) (defun window-backing-store (window) ;; setf'able (declare (type window window) (clx-values (member :not-useful :when-mapped :always)))) (defun window-backing-planes (window) ;; setf'able (declare (type window window) (clx-values pixel))) (defun window-backing-pixel (window) ;; setf'able (declare (type window window) (clx-values pixel))) (defun window-save-under (window) ;; setf'able (declare (type window window) (clx-values (member :on :off)))) (defun window-event-mask (window) ;; setf'able (declare (type window window) (clx-values mask32))) (defun window-do-not-propagate-mask (window) ;; setf'able (declare (type window window) (clx-values mask32))) (defun window-override-redirect (window) ;; setf'able (declare (type window window) (clx-values (member :on :off)))) (defun window-colormap (window) (declare (type window window) (clx-values (or null colormap)))) (defsetf window-colormap (window) (colormap) (declare (type window window) (type (or (member :copy) colormap) colormap))) (defsetf window-cursor (window) (cursor) (declare (type window window) (type (or (member :none) cursor) cursor))) (defun window-colormap-installed-p (window) (declare (type window window) (clx-values boolean))) (defun window-all-event-masks (window) (declare (type window window) (clx-values mask32))) (defun window-map-state (window) (declare (type window window) (clx-values (member :unmapped :unviewable :viewable)))) (defsetf drawable-x (window) (x) (declare (type window window) (type int16 x))) (defsetf drawable-y (window) (y) (declare (type window window) (type int16 y))) (defsetf drawable-width (window) (width) ;; Inside width, excluding border. (declare (type window window) (type card16 width))) (defsetf drawable-height (window) (height) ;; Inside height, excluding border. (declare (type window window) (type card16 height))) (defsetf drawable-border-width (window) (border-width) (declare (type window window) (type card16 border-width))) (defsetf window-priority (window &optional sibling) (mode) ;; A bit strange, but retains setf form. (declare (type window window) (type (or null window) sibling) (type (member :above :below :top-if :bottom-if :opposite) mode))) (defmacro with-state ((drawable) &body body) ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and ;; ConfigureWindow. The body is not surrounded by a with-display. Within the ;; indefinite scope of the body, on a per-process basis in a multi-process ;; environment, the first call within an Accessor Group on the specified drawable ;; (the object, not just the variable) causes the complete results of the protocol ;; request to be retained, and returned in any subsequent accessor calls. Calls ;; within a Setf Group are delayed, and executed in a single request on exit from ;; the body. In addition, if a call on a function within an Accessor Group follows ;; a call on a function in the corresponding Setf Group, then all delayed setfs for ;; that group are executed, any retained accessor information for that group is ;; discarded, the corresponding protocol request is (re)issued, and the results are ;; (again) retained, and returned in any subsequent accessor calls. ;; Accessor Group A (for GetWindowAttributes): ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity, ;; window-backing-store, window-backing-planes, window-backing-pixel, ;; window-save-under, window-colormap, window-colormap-installed-p, ;; window-map-state, window-all-event-masks, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect ;; Setf Group A (for ChangeWindowAttributes): ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes, ;; window-backing-pixel, window-save-under, window-event-mask, ;; window-do-not-propagate-mask, window-override-redirect, window-colormap, ;; window-cursor ;; Accessor Group G (for GetGeometry): ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width, ;; drawable-height, drawable-border-width ;; Setf Group G (for ConfigureWindow): ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width, ;; window-priority ) (defun destroy-window (window) (declare (type window window))) (defun destroy-subwindows (window) (declare (type window window))) (defun add-to-save-set (window) (declare (type window window))) (defun remove-from-save-set (window) (declare (type window window))) (defun reparent-window (window parent x y) (declare (type window window parent) (type int16 x y))) (defun map-window (window) (declare (type window window))) (defun map-subwindows (window) (declare (type window window))) (defun unmap-window (window) (declare (type window window))) (defun unmap-subwindows (window) (declare (type window window))) (defun circulate-window-up (window) (declare (type window window))) (defun circulate-window-down (window) (declare (type window window))) (defun drawable-root (drawable) (declare (type drawable drawable) (clx-values window))) (defun drawable-depth (drawable) (declare (type drawable drawable) (clx-values card8))) (defun drawable-x (drawable) (declare (type drawable drawable) (clx-values int16))) (defun drawable-y (drawable) (declare (type drawable drawable) (clx-values int16))) (defun drawable-width (drawable) ;; For windows, inside width, excluding border. (declare (type drawable drawable) (clx-values card16))) (defun drawable-height (drawable) ;; For windows, inside height, excluding border. (declare (type drawable drawable) (clx-values card16))) (defun drawable-border-width (drawable) (declare (type drawable drawable) (clx-values card16))) (defun query-tree (window &key (result-type 'list)) (declare (type window window) (type type result-type) (clx-values (clx-sequence window) parent root))) (defun change-property (window property data type format &key (mode :replace) (start 0) end transform) ;; Start and end affect sub-sequence extracted from data. ;; Transform is applied to each extracted element. (declare (type window window) (type xatom property type) (type (member 8 16 32) format) (type sequence data) (type (member :replace :prepend :append) mode) (type array-index start) (type (or null array-index) end) (type (or null (function (t) integer)) transform))) (defun delete-property (window property) (declare (type window window) (type xatom property))) (defun get-property (window property &key type (start 0) end delete-p (result-type 'list) transform) ;; Transform is applied to each integer retrieved. ;; Nil is returned for type when the protocol returns None. (declare (type window window) (type xatom property) (type (or null xatom) type) (type array-index start) (type (or null array-index) end) (type boolean delete-p) (type type result-type) (type (or null (function (integer) t)) transform) (clx-values data type format bytes-after))) (defun rotate-properties (window properties &optional (delta 1)) ;; Postive rotates left, negative rotates right (opposite of actual protocol request). (declare (type window window) (type (clx-sequence xatom) properties) (type int16 delta))) (defun list-properties (window &key (result-type 'list)) (declare (type window window) (type type result-type) (clx-values (clx-sequence keyword)))) ;; Although atom-ids are not visible in the normal user interface, atom-ids might ;; appear in window properties and other user data, so conversion hooks are needed. (defun intern-atom (display name) (declare (type display display) (type xatom name) (clx-values resource-id))) (defun find-atom (display name) (declare (type display display) (type xatom name) (clx-values (or null resource-id)))) (defun atom-name (display atom-id) (declare (type display display) (type resource-id atom-id) (clx-values keyword))) (defun selection-owner (display selection) (declare (type display display) (type xatom selection) (clx-values (or null window)))) (defsetf selection-owner (display selection &optional time) (owner) ;; A bit strange, but retains setf form. (declare (type display display) (type xatom selection) (type (or null window) owner) (type timestamp time))) (defun convert-selection (selection type requestor &optional property time) (declare (type xatom selection type) (type window requestor) (type (or null xatom) property) (type timestamp time))) (defun send-event (window event-key event-mask &rest args &key propagate-p display &allow-other-keys) ;; Additional arguments depend on event-key, and are as specified further below ;; with declare-event, except that both resource-ids and resource objects are ;; accepted in the event components. The display argument is only required if the ;; window is :pointer-window or :input-focus. If an argument has synonyms, it is ;; only necessary to supply a value for one of them; it is an error to specify ;; different values for synonyms. (declare (type (or window (member :pointer-window :input-focus)) window) (type (or null event-key) event-key) (type event-mask event-mask) (type boolean propagate-p) (type (or null display) display))) (defun grab-pointer (window event-mask &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) (declare (type window window) (type pointer-event-mask event-mask) (type boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor) (type timestamp time) (clx-values grab-status))) (defun ungrab-pointer (display &key time) (declare (type display display) (type timestamp time))) (defun grab-button (window button event-mask &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p confine-to cursor) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers) (type pointer-event-mask event-mask) (type boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor))) (defun ungrab-button (window button &key (modifiers 0)) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers))) (defun change-active-pointer-grab (display event-mask &optional cursor time) (declare (type display display) (type pointer-event-mask event-mask) (type (or null cursor) cursor) (type timestamp time))) (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) (declare (type window window) (type boolean owner-p sync-pointer-p sync-keyboard-p) (type timestamp time) (clx-values grab-status))) (defun ungrab-keyboard (display &key time) (declare (type display display) (type timestamp time))) (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) (declare (type window window) (type boolean owner-p sync-pointer-p sync-keyboard-p) (type (or (member :any) card8) key) (type modifier-mask modifiers))) (defun ungrab-key (window key &key (modifiers 0)) (declare (type window window) (type (or (member :any) card8) key) (type modifier-mask modifiers))) (defun allow-events (display mode &optional time) (declare (type display display) (type (member :async-pointer :sync-pointer :reply-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both) mode) (type timestamp time))) (defun grab-server (display) (declare (type display display))) (defun ungrab-server (display) (declare (type display display))) (defmacro with-server-grabbed ((display) &body body) ;; The body is not surrounded by a with-display. ) (defun query-pointer (window) (declare (type window window) (clx-values x y same-screen-p child mask root-x root-y root))) (defun pointer-position (window) (declare (type window window) (clx-values x y same-screen-p))) (defun global-pointer-position (display) (declare (type display display) (clx-values root-x root-y root))) (defun motion-events (window &key start stop (result-type 'list)) (declare (type window window) (type timestamp start stop) (type type result-type) (clx-values (repeat-seq (int16 x) (int16 y) (timestamp time))))) (defun translate-coordinates (src src-x src-y dst) ;; If src and dst are not on the same screen, nil is returned. (declare (type window src) (type int16 src-x src-y) (type window dst) (clx-values dst-x dst-y child))) (defun warp-pointer (dst dst-x dst-y) (declare (type window dst) (type int16 dst-x dst-y))) (defun warp-pointer-relative (display x-off y-off) (declare (type display display) (type int16 x-off y-off))) (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. A null src-width or ;; src-height translates into a zero value in the protocol request. (declare (type window dst src) (type int16 dst-x dst-y src-x src-y) (type (or null card16) src-width src-height))) (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. A null src-width or ;; src-height translates into a zero value in the protocol request. (declare (type window src) (type int16 x-off y-off src-x src-y) (type (or null card16) src-width src-height))) (defun set-input-focus (display focus revert-to &optional time) ;; Setf ought to allow multiple values. (declare (type display display) (type (or (member :none :pointer-root) window) focus) (type (member :none :parent :pointer-root) revert-to) (type timestamp time))) (defun input-focus (display) (declare (type display display) (clx-values focus revert-to))) (defun query-keymap (display) (declare (type display display) (clx-values (bit-vector 256)))) (defun open-font (display name) ;; Font objects may be cached and reference counted locally within the display ;; object. This function might not execute a with-display if the font is cached. ;; The protocol QueryFont request happens on-demand under the covers. (declare (type display display) (type stringable name) (clx-values font))) ;; We probably want a per-font bit to indicate whether caching on ;; text-extents/width calls is desirable. But what to name it? (defun discard-font-info (font) ;; Discards any state that can be re-obtained with QueryFont. This is simply ;; a performance hint for memory-limited systems. (declare (type font font))) ;; This can be signalled anywhere a pseudo font access fails. (define-condition invalid-font error font) ;; Note: font-font-info removed. (defun font-name (font) ;; Returns nil for a pseudo font returned by gcontext-font. (declare (type font font) (clx-values (or null string)))) (defun font-direction (font) (declare (type font font) (clx-values draw-direction))) (defun font-min-char (font) (declare (type font font) (clx-values card16))) (defun font-max-char (font) (declare (type font font) (clx-values card16))) (defun font-min-byte1 (font) (declare (type font font) (clx-values card8))) (defun font-max-byte1 (font) (declare (type font font) (clx-values card8))) (defun font-min-byte2 (font) (declare (type font font) (clx-values card8))) (defun font-max-byte2 (font) (declare (type font font) (clx-values card8))) (defun font-all-chars-exist-p (font) (declare (type font font) (clx-values boolean))) (defun font-default-char (font) (declare (type font font) (clx-values card16))) (defun font-ascent (font) (declare (type font font) (clx-values int16))) (defun font-descent (font) (declare (type font font) (clx-values int16))) ;; The list contains alternating keywords and int32s. (deftype font-props () 'list) (defun font-properties (font) (declare (type font font) (clx-values font-props))) (defun font-property (font name) (declare (type font font) (type keyword name) (clx-values (or null int32)))) ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: (defun char- (font index) ;; Note: I have tentatively chosen to return nil for an out-of-bounds index ;; (or an in-bounds index on a pseudo font), although returning zero or ;; signalling might be better. (declare (type font font) (type card16 index) (clx-values (or null int16)))) (defun max-char- (font) ;; Note: I have tentatively chosen separate accessors over allowing :min and ;; :max as an index above. (declare (type font font) (clx-values int16))) (defun min-char- (font) (declare (type font font) (clx-values int16))) ;; Note: char16- accessors could be defined to accept two-byte indexes. (defun close-font (font) ;; This might not generate a protocol request if the font is reference ;; counted locally or if it is a pseudo font. (declare (type font font))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) (declare (type display display) (type string pattern) (type card16 max-fonts) (type type result-type) (clx-values (clx-sequence string)))) (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) ;; Returns "pseudo" fonts that contain basic font metrics and properties, but ;; no per-character metrics and no resource-ids. These pseudo fonts will be ;; converted (internally) to real fonts dynamically as needed, by issuing an ;; OpenFont request. However, the OpenFont might fail, in which case the ;; invalid-font error can arise. (declare (type display display) (type string pattern) (type card16 max-fonts) (type type result-type) (clx-values (clx-sequence font)))) (defun font-path (display &key (result-type 'list)) (declare (type display display) (type type result-type) (clx-values (clx-sequence (or string pathname))))) (defsetf font-path (display) (paths) (declare (type display display) (type (clx-sequence (or string pathname)) paths))) (defun create-pixmap (&key width height depth drawable) (declare (type card16 width height) (type card8 depth) (type drawable drawable) (clx-values pixmap))) (defun free-pixmap (pixmap) (declare (type pixmap pixmap))) (defun create-gcontext (&key drawable function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes (cache-p t)) ;; Only non-nil components are passed on in the request, but for effective caching ;; assumptions have to be made about what the actual protocol defaults are. For ;; all gcontext components, a value of nil causes the default gcontext value to be ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented ;; as a list. Note: use of stringable as font will cause an implicit open-font. ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext ;; component will have no effect unless the new value differs from the cached ;; value. Component changes (setfs and with-gcontext) are always deferred ;; regardless of the cache mode, and sent over the protocol only when required by a ;; local operation or by an explicit call to force-gcontext-changes. (declare (type drawable drawable) (type (or null boole-constant) function) (type (or null pixel) plane-mask foreground background) (type (or null card16) line-width dash-offset) (type (or null int16) ts-x ts-y clip-x clip-y) (type (or null (member :solid :dash :double-dash)) line-style) (type (or null (member :not-last :butt :round :projecting)) cap-style) (type (or null (member :miter :round :bevel)) join-style) (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) (type (or null (member :even-odd :winding)) fill-rule) (type (or null (member :chord :pie-slice)) arc-mode) (type (or null pixmap) tile stipple) (type (or null fontable) font) (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) (type (or null (member :on :off)) exposures) (type (or null (member :none) pixmap rect-seq) clip-mask) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) (type (or null (or card8 (clx-sequence card8))) dashes) (type boolean cache) (clx-values gcontext))) ;; For each argument to create-gcontext (except font, clip-mask and ;; clip-ordering) declared as (type ), there is an accessor: (defun gcontext- (gcontext) ;; The value will be nil if the last value stored is unknown (e.g., the cache was ;; off, or the component was copied from a gcontext with unknown state). (declare (type gcontext gcontext) (clx-values ))) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type (or null ) ), there is a setf for the corresponding accessor: (defsetf gcontext- (gcontext) (value) (declare (type gcontext gcontext) (type value))) (defun gcontext-font (gcontext &optional metrics-p) ;; If the stored font is known, it is returned. If it is not known and ;; metrics-p is false, then nil is returned. If it is not known and ;; metrics-p is true, then a pseudo font is returned. Full metric and ;; property information can be obtained, but the font does not have a name or ;; a resource-id, and attempts to use it where a resource-id is required will ;; result in an invalid-font error. (declare (type gcontext gcontext) (type boolean metrics-p) (clx-values (or null font)))) (defun gcontext-clip-mask (gcontext) (declare (type gcontext gcontext) (clx-values (or null (member :none) pixmap rect-seq) (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))) (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) ;; Is nil illegal here, or is it transformed to a vector? ;; A bit strange, but retains setf form. (declare (type gcontext gcontext) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) (type (or (member :none) pixmap rect-seq) clip-mask))) (defun force-gcontext-changes (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext))) (defmacro with-gcontext ((gcontext &key function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dashes dash-offset) &body body) ;; Changes gcontext components within the dynamic scope of the body (i.e., ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process ;; environment. The values are all evaluated before bindings are performed. The ;; body is not surrounded by a with-display. If cache-p is nil or the some ;; component states are unknown, this will implement save/restore by creating a ;; temporary gcontext and doing gcontext-components to and from it. ) (defun copy-gcontext-components (src dst &rest keys) (declare (type gcontext src dst) (type (clx-list gcontext-key) keys))) (defun copy-gcontext (src dst) (declare (type gcontext src dst)) ;; Copies all components. ) (defun free-gcontext (gcontext) (declare (type gcontext gcontext))) (defun clear-area (window &key (x 0) (y 0) width height exposures-p) ;; Passing in a zero width or height is a no-op. A null width or height translates ;; into a zero value in the protocol request. (declare (type window window) (type int16 x y) (type (or null card16) width height) (type boolean exposures-p))) (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type int16 src-x src-y dst-x dst-y) (type card16 width height))) (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type pixel plane) (type int16 src-x src-y dst-x dst-y) (type card16 width height))) (defun draw-point (drawable gcontext x y) ;; Should be clever about appending to existing buffered protocol request, provided ;; gcontext has not been modified. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y))) (defun draw-points (drawable gcontext points &optional relative-p) (declare (type drawable drawable) (type gcontext gcontext) (type point-seq points) (type boolean relative-p))) (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) ;; Should be clever about appending to existing buffered protocol request, provided ;; gcontext has not been modified. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x1 y1 x2 y2) (type boolean relative-p))) (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) (declare (type drawable drawable) (type gcontext gcontext) (type point-seq points) (type boolean relative-p fill-p) (type (member :complex :non-convex :convex) shape))) (defun draw-segments (drawable gcontext segments) (declare (type drawable drawable) (type gcontext gcontext) (type seg-seq segments))) (defun draw-rectangle (drawable gcontext x y width height &optional fill-p) ;; Should be clever about appending to existing buffered protocol request, provided ;; gcontext has not been modified. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type boolean fill-p))) (defun draw-rectangles (drawable gcontext rectangles &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type rect-seq rectangles) (type boolean fill-p))) (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) ;; Should be clever about appending to existing buffered protocol request, provided ;; gcontext has not been modified. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type angle angle1 angle2) (type boolean fill-p))) (defun draw-arcs (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type arc-seq arcs) (type boolean fill-p))) ;; The following image routines are bare minimum. It may be useful to define some ;; form of "image" object to hide representation details and format conversions. It ;; also may be useful to provide stream-oriented interfaces for reading and writing ;; the data. (defun put-raw-image (drawable gcontext data &key (start 0) depth x y width height (left-pad 0) format) ;; Data must be a sequence of 8-bit quantities, already in the appropriate format ;; for transmission; the caller is responsible for all byte and bit swapping and ;; compaction. Start is the starting index in data; the end is computed from the ;; other arguments. (declare (type drawable drawable) (type gcontext gcontext) (type (clx-sequence card8) data) (type array-index start) (type card8 depth left-pad) (type int16 x y) (type card16 width height) (type (member :bitmap :xy-pixmap :z-pixmap) format))) (defun get-raw-image (drawable &key data (start 0) x y width height (plane-mask 0xffffffff) format (result-type '(vector (unsigned-byte 8)))) ;; If data is given, it is modified in place (and returned), otherwise a new ;; sequence is created and returned, with a size computed from the other arguments ;; and the returned depth. The sequence is filled with 8-bit quantities, in ;; transmission format; the caller is responsible for any byte and bit swapping and ;; compaction required for further local use. (declare (type drawable drawable) (type (or null (clx-sequence card8)) data) (type array-index start) (type int16 x y) (type card16 width height) (type pixel plane-mask) (type (member :xy-pixmap :z-pixmap) format) (clx-values (clx-sequence card8) depth visual-info))) (defun translate-default (src src-start src-end font dst dst-start) ;; dst is guaranteed to have room for (- src-end src-start) integer elements, ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends ;; on context. font is the current font, if known. The function should ;; translate as many elements of src as possible into indexes in the current ;; font, and store them into dst. The first return value should be the src ;; index of the first untranslated element. If no further elements need to ;; be translated, the second return value should be nil. If a horizontal ;; motion is required before further translation, the second return value ;; should be the delta in x coordinate. If a font change is required for ;; further translation, the second return value should be the new font. If ;; known, the pixel width of the translated text can be returned as the third ;; value; this can allow for appending of subsequent output to the same ;; protocol request, if no overall width has been specified at the higher ;; level. (declare (type sequence src) (type array-index src-start src-end dst-start) (type (or null font) font) (type vector dst) (clx-values array-index (or null int16 font) (or null int32)))) ;; There is a question below of whether translate should always be required, or ;; if not, what the default should be or where it should come from. For ;; example, the default could be something that expected a string as src and ;; translated the CL standard character set to ASCII indexes, and ignored fonts ;; and bits. Or the default could expect a string but otherwise be "system ;; dependent". Or the default could be something that expected a vector of ;; integers and did no translation. Or the default could come from the ;; gcontext (but what about text-extents and text-width?). (defun text-extents (font sequence &key (start 0) end translate) ;; If multiple fonts are involved, font-ascent and font-descent will be the ;; maximums. If multiple directions are involved, the direction will be nil. ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font) (type translate translate) (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index)))) (defun text-width (font sequence &key (start 0) end translate) ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font) (type translate translate) (clx-values int32 (or null array-index)))) ;; This controls the element size of the dst buffer given to translate. If ;; :default is specified, the size will be based on the current font, if known, ;; and otherwise 16 will be used. [An alternative would be to pass the buffer ;; size to translate, and allow it to return the desired size if it doesn't ;; like the current size. The problem is that the protocol doesn't allow ;; switching within a single request, so to allow switching would require ;; knowing the width of text, which isn't necessarily known. We could call ;; text-width to compute it, but perhaps that is doing too many favors?] [An ;; additional possibility is to allow an index-size of :two-byte, in which case ;; translate would be given a double-length 8-bit array, and translate would be ;; expected to store first-byte/second-byte instead of 16-bit integers.] (deftype index-size () '(member :default 8 16)) ;; In the glyph functions below, if width is specified, it is assumed to be the ;; total pixel width of whatever string of glyphs is actually drawn. ;; Specifying width will allow for appending the output of subsequent calls to ;; the same protocol request, provided gcontext has not been modified in the ;; interim. If width is not specified, appending of subsequent output might ;; not occur (unless translate returns the width). Specifying width is simply ;; a hint, for performance. (defun draw-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type translate translate) (type (or null int32) width) (type index-size size) (clx-values boolean (or null int32)))) (defun draw-glyphs (drawable gcontext x y sequence &key (start 0) end translate width (size :default)) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type sequence sequence) (type array-index start) (type (or null array-index) end) (type (or null int32) width) (type translate translate) (type index-size size) (clx-values (or null array-index) (or null int32)))) (defun draw-image-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is overall width, if known. An initial font change is ;; allowed from translate. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type translate translate) (type (or null int32) width) (type index-size size) (clx-values boolean (or null int32)))) (defun draw-image-glyphs (drawable gcontext x y sequence &key (start 0) end width translate (size :default)) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type sequence sequence) (type array-index start) (type (or null array-index) end) (type (or null int32) width) (type translate translate) (type index-size size) (clx-values (or null array-index) (or null int32)))) (defun create-colormap (visual window &optional alloc-p) (declare (type visual-info visual) (type window window) (type boolean alloc-p) (clx-values colormap))) (defun free-colormap (colormap) (declare (type colormap colormap))) (defun copy-colormap-and-free (colormap) (declare (type colormap colormap) (clx-values colormap))) (defun install-colormap (colormap) (declare (type colormap colormap))) (defun uninstall-colormap (colormap) (declare (type colormap colormap))) (defun installed-colormaps (window &key (result-type 'list)) (declare (type window window) (type type result-type) (clx-values (clx-sequence colormap)))) (defun alloc-color (colormap color) (declare (type colormap colormap) (type (or stringable color) color) (clx-values pixel screen-color exact-color))) (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors planes) (type boolean contiguous-p) (type type result-type) (clx-values (clx-sequence pixel) (clx-sequence mask)))) (defun alloc-color-planes (colormap colors &key (reds 0) (greens 0) (blues 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors reds greens blues) (type boolean contiguous-p) (type type result-type) (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))) (defun free-colors (colormap pixels &optional (plane-mask 0)) (declare (type colormap colormap) (type (clx-sequence pixel) pixels) (type pixel plane-mask))) (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) (declare (type colormap colormap) (type pixel pixel) (type (or stringable color) spec) (type boolean red-p green-p blue-p))) (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) ;; If stringables are specified for colors, it is unspecified whether all ;; stringables are first resolved and then a single StoreColors protocol request is ;; issued, or whether multiple StoreColors protocol requests are issued. (declare (type colormap colormap) (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs) (type boolean red-p green-p blue-p))) (defun query-colors (colormap pixels &key (result-type 'list)) (declare (type colormap colormap) (type (clx-sequence pixel) pixels) (type type result-type) (clx-values (clx-sequence color)))) (defun lookup-color (colormap name) (declare (type colormap colormap) (type stringable name) (clx-values screen-color true-color))) (defun create-cursor (&key source mask x y foreground background) (declare (type pixmap source) (type (or null pixmap) mask) (type card16 x y) (type color foreground background) (clx-values cursor))) (defun create-glyph-cursor (&key source-font source-char mask-font mask-char foreground background) (declare (type font source-font) (type card16 source-char) (type (or null font) mask-font) (type (or null card16) mask-char) (type color foreground background) (clx-values cursor))) (defun free-cursor (cursor) (declare (type cursor cursor))) (defun recolor-cursor (cursor foreground background) (declare (type cursor cursor) (type color foreground background))) (defun query-best-cursor (width height drawable) (declare (type card16 width height) (type drawable display) (clx-values width height))) (defun query-best-tile (width height drawable) (declare (type card16 width height) (type drawable drawable) (clx-values width height))) (defun query-best-stipple (width height drawable) (declare (type card16 width height) (type drawable drawable) (clx-values width height))) (defun query-extension (display name) (declare (type display display) (type stringable name) (clx-values major-opcode first-event first-error))) (defun list-extensions (display &key (result-type 'list)) (declare (type display display) (type type result-type) (clx-values (clx-sequence string)))) ;; Should pointer-mapping setf be changed to set-pointer-mapping? (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) ;; Can signal device-busy. ;; Setf ought to allow multiple values. ;; Returns true for success, nil for failure (declare (type display display) (type (clx-sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5) (clx-values (member :success :busy :failed)))) (defun modifier-mapping (display) ;; each value is a list of card8s (declare (type display display) (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))) ;; Either we will want lots of defconstants for well-known values, or perhaps ;; an integer-to-keyword translation function for well-known values. (defun change-keyboard-mapping (display keysyms &key (start 0) end (first-keycode start)) ;; start/end give subrange of keysyms ;; first-keycode is the first-keycode to store at (declare (type display display) (type (array * (* *)) keysyms) (type array-index start) (type (or null array-index) end) (type card8 first-keycode))) (defun keyboard-mapping (display &key first-keycode start end data) ;; First-keycode specifies which keycode to start at (defaults to ;; min-keycode). Start specifies where (in result) to put first-keycode ;; (defaults to first-keycode). (- end start) is the number of keycodes to ;; get (end defaults to (1+ max-keycode)). If data is specified, the results ;; are put there. (declare (type display display) (type (or null card8) first-keycode) (type (or null array-index) start end) (type (or null (array * (* *))) data) (clx-values (array * (* *))))) (defun change-keyboard-control (display &key key-click-percent bell-percent bell-pitch bell-duration led led-mode key auto-repeat-mode) (declare (type display display) (type (or null (member :default) int16) key-click-percent bell-percent bell-pitch bell-duration) (type (or null card8) led key) (type (or null (member :on :off)) led-mode) (type (or null (member :on :off :default)) auto-repeat-mode))) (defun keyboard-control (display) (declare (type display display) (clx-values key-click-percent bell-percent bell-pitch bell-duration led-mask global-auto-repeat auto-repeats))) (defun bell (display &optional (percent-from-normal 0)) ;; It is assumed that an eventual audio extension to X will provide more complete ;; control. (declare (type display display) (type int8 percent-from-normal))) (defun pointer-mapping (display &key (result-type 'list)) (declare (type display display) (type type result-type) (clx-values (clx-sequence card8)))) (defsetf pointer-mapping (display) (map) ;; Can signal device-busy. (declare (type display display) (type (clx-sequence card8) map))) (defun change-pointer-control (display &key acceleration threshold) ;; Acceleration is rationalized if necessary. (declare (type display display) (type (or null (member :default) number) acceleration) (type (or null (member :default) integer) threshold))) (defun pointer-control (display) (declare (type display display) (clx-values acceleration threshold))) (defun set-screen-saver (display timeout interval blanking exposures) ;; Setf ought to allow multiple values. ;; Timeout and interval are in seconds, will be rounded to minutes. (declare (type display display) (type (or (member :default) int16) timeout interval) (type (member :on :off :default) blanking exposures))) (defun screen-saver (display) ;; Returns timeout and interval in seconds. (declare (type display display) (clx-values timeout interval blanking exposures))) (defun activate-screen-saver (display) (declare (type display display))) (defun reset-screen-saver (display) (declare (type display display))) (defun add-access-host (display host) ;; A string must be acceptable as a host, but otherwise the possible types for host ;; are not constrained, and will likely be very system dependent. (declare (type display display))) (defun remove-access-host (display host) ;; A string must be acceptable as a host, but otherwise the possible types for host ;; are not constrained, and will likely be very system dependent. (declare (type display display))) (defun access-hosts (display &key (result-type 'list)) ;; The type of host objects returned is not constrained, except that the hosts must ;; be acceptable to add-access-host and remove-access-host. (declare (type display display) (type type result-type) (clx-values (clx-sequence host) enabled-p))) (defun access-control (display) ;; setf'able (declare (type display display) (clx-values boolean))) (defun close-down-mode (display) ;; setf'able ;; Cached locally in display object. (declare (type display display) (clx-values (member :destroy :retain-permanent :retain-temporary)))) (defun kill-client (display resource-id) (declare (type display display) (type resource-id resource-id))) (defun kill-temporary-clients (display) (declare (type display display))) (defun make-event-mask (&rest keys) ;; This is only defined for core events. ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask. (declare (type (clx-list event-mask-class) keys) (clx-values mask32))) (defun make-event-keys (event-mask) ;; This is only defined for core events. (declare (type mask32 event-mask) (clx-values (clx-list event-mask-class)))) (defun make-state-mask (&rest keys) ;; Useful for constructing modifier-mask, state-mask. (declare (type (clx-list state-mask-key) keys) (clx-values mask16))) (defun make-state-keys (state-mask) (declare (type mask16 mask) (clx-values (clx-list state-mask-key)))) (defmacro with-event-queue ((display) &body body) ;; Grants exclusive access to event queue. ) (defun event-listen (display &optional (timeout 0)) (declare (type display display) (type (or null number) timeout) (clx-values (or null number) (or null (member :timeout) (not null)))) ;; Returns the number of events queued locally, if any, else nil. Hangs ;; waiting for events, forever if timeout is nil, else for the specified ;; number of seconds. The second value returned is :timeout if the ;; operation timed out, and some other non-nil value if an EOF has been ;; detected. ) (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) ;; If force-output-p is true, first invokes display-force-output. Invokes ;; handler on each queued event until handler returns non-nil, and that ;; returned object is then returned by process-event. If peek-p is true, ;; then the event is not removed from the queue. If discard-p is true, then ;; events for which handler returns nil are removed from the queue, ;; otherwise they are left in place. Hangs until non-nil is generated for ;; some event, or for the specified timeout (in seconds, if given); however, ;; it is acceptable for an implementation to wait only once on network data, ;; and therefore timeout prematurely. Returns nil on timeout or EOF, with a ;; second return value being :timeout for a timeout and some other non-nil ;; value for EOF. If handler is a sequence, it is expected to contain ;; handler functions specific to each event class; the event code is used to ;; index the sequence, fetching the appropriate handler. The arguments to ;; the handler are described further below using declare-event. If ;; process-event is invoked recursively, the nested invocation begins with ;; the event after the one currently being processed. (declare (type display display) (type (or (clx-sequence (function (&key &allow-other-keys) t)) (function (&key &allow-other-keys) t)) handler) (type (or null number) timeout) (type boolean peek-p))) (defun make-event-handlers (&key (type 'array) default) (declare (type t type) ;Sequence type specifier (type function default) (clx-values sequence)) ;Default handler for initial content ;; Makes a handler sequence suitable for process-event ) (defun event-handler (handlers event-key) (declare (type sequence handlers) (type event-key event-key) (clx-values function)) ;; Accessor for a handler sequence ) (defsetf event-handler (handlers event-key) (handler) (declare (type sequence handlers) (type event-key event-key) (type function handler) (clx-values function)) ;; Setf accessor for a handler sequence ) (defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t)) &body clauses) (declare (arglist (display &key timeout peek-p discard-p force-output-p) (event-or-events ((&rest args) |...|) &body body) |...|)) ;; If force-output-p is true, first invokes display-force-output. Executes ;; the matching clause for each queued event until a clause returns non-nil, ;; and that returned object is then returned by event-case. If peek-p is ;; true, then the event is not removed from the queue. If discard-p is ;; true, then events for which the clause returns nil are removed from the ;; queue, otherwise they are left in place. Hangs until non-nil is ;; generated for some event, or for the specified timeout (in seconds, if ;; given); however, it is acceptable for an implementation to wait only once ;; on network data, and therefore timeout prematurely. Returns nil on ;; timeout or EOF with a second return value being :timeout for a timeout ;; and some other non-nil value for EOF. In each clause, event-or-events is ;; an event-key or a list of event-keys (but they need not be typed as ;; keywords) or the symbol t or otherwise (but only in the last clause). ;; The keys are not evaluated, and it is an error for the same key to appear ;; in more than one clause. Args is the list of event components of ;; interest; corresponding values (if any) are bound to variables with these ;; names (i.e., the args are variable names, not keywords, the keywords are ;; derived from the variable names). An arg can also be a (keyword var) ;; form, as for keyword args in a lambda lists. If no t/otherwise clause ;; appears, it is equivalent to having one that returns nil. If ;; process-event is invoked recursively, the nested invocation begins with ;; the event after the one currently being processed. ) (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) &body clauses) ;; The clauses of event-cond are of the form: ;; (event-or-events binding-list test-form . body-forms) ;; ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they ;; need not be typed as keywords) or the symbol t ;; or otherwise (but only in the last clause). If ;; no t/otherwise clause appears, it is equivalent ;; to having one that returns nil. The keys are ;; not evaluated, and it is an error for the same ;; key to appear in more than one clause. ;; ;; BINDING-LIST The list of event components of interest. ;; corresponding values (if any) are bound to ;; variables with these names (i.e., the binding-list ;; has variable names, not keywords, the keywords are ;; derived from the variable names). An arg can also ;; be a (keyword var) form, as for keyword args in a ;; lambda list. ;; ;; The matching TEST-FORM for each queued event is executed until a ;; clause's test-form returns non-nil. Then the BODY-FORMS are ;; evaluated, returning the (possibly multiple) values of the last ;; form from event-cond. If there are no body-forms then, if the ;; test-form is non-nil, the value of the test-form is returned as a ;; single value. ;; ;; Options: ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no ;; input is pending. ;; ;; PEEK-P When true, then the event is not removed from the queue. ;; ;; DISCARD-P When true, then events for which the clause returns nil ;; are removed from the queue, otherwise they are left in place. ;; ;; TIMEOUT If NIL, hang until non-nil is generated for some event's ;; test-form. Otherwise return NIL after TIMEOUT seconds have ;; elapsed. NIL is also returned whenever EOF is read. ;; Whenever NIL is returned a second value is returned which ;; is either :TIMEOUT if a timeout occurred or some other ;; non-NIL value if an EOF is detected. ;; (declare (arglist (display &key timeout peek-p discard-p force-output-p) (event-or-events (&rest args) test-form &body body) |...|)) ) (defun discard-current-event (display) (declare (type display display) (clx-values boolean)) ;; Discard the current event for DISPLAY. ;; Returns NIL when the event queue is empty, else T. ;; To ensure events aren't ignored, application code should only call ;; this when throwing out of event-case or process-next-event, or from ;; inside even-case, event-cond or process-event when :peek-p is T and ;; :discard-p is NIL. ) (defmacro declare-event (event-codes &rest declares) ;; Used to indicate the keyword arguments for handler functions in process-event ;; and event-case. In the declares, an argument listed as (name1 name2) indicates ;; synonyms for the same argument. All process-event handlers can have ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword ;; arguments, and an event-case clause can also have event-key and send-event-p as ;; arguments. (declare (arglist event-key-or-keys &rest (type &rest keywords)))) (declare-event (:key-press :key-release :button-press :button-release) (card16 sequence) (window (window event-window) root) ((or null window) child) (boolean same-screen-p) (int16 x y root-x root-y) (card16 state) ((or null card32) time) ;; for key-press and key-release, code is the keycode ;; for button-press and button-release, code is the button number (card8 code)) (declare-event :motion-notify (card16 sequence) (window (window event-window) root) ((or null window) child) (boolean same-screen-p) (int16 x y root-x root-y) (card16 state) ((or null card32) time) (boolean hint-p)) (declare-event (:enter-notify :leave-notify) (card16 sequence) (window (window event-window) root) ((or null window) child) (boolean same-screen-p) (int16 x y root-x root-y) (card16 state) ((or null card32) time) ((member :normal :grab :ungrab) mode) ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind) (boolean focus-p)) (declare-event (:focus-in :focus-out) (card16 sequence) (window (window event-window)) ((member :normal :while-grabbed :grab :ungrab) mode) ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none) kind)) (declare-event :keymap-notify ((bit-vector 256) keymap)) (declare-event :exposure (card16 sequence) (window (window event-window)) (card16 x y width height count)) (declare-event :graphics-exposure (card16 sequence) (drawable (drawable event-window)) (card16 x y width height count) (card8 major) (card16 minor)) (declare-event :no-exposure (card16 sequence) (drawable (drawable event-window)) (card8 major) (card16 minor)) (declare-event :visibility-notify (card16 sequence) (window (window event-window)) ((member :unobscured :partially-obscured :fully-obscured) state)) (declare-event :create-notify (card16 sequence) (window window (parent event-window)) (int16 x y) (card16 width height border-width) (boolean override-redirect-p)) (declare-event :destroy-notify (card16 sequence) (window event-window window)) (declare-event :unmap-notify (card16 sequence) (window event-window window) (boolean configure-p)) (declare-event :map-notify (card16 sequence) (window event-window window) (boolean override-redirect-p)) (declare-event :map-request (card16 sequence) (window (parent event-window) window)) (declare-event :reparent-notify (card16 sequence) (window event-window window parent) (int16 x y) (boolean override-redirect-p)) (declare-event :configure-notify (card16 sequence) (window event-window window) (int16 x y) (card16 width height border-width) ((or null window) above-sibling) (boolean override-redirect-p)) (declare-event :gravity-notify (card16 sequence) (window event-window window) (int16 x y)) (declare-event :resize-request (card16 sequence) (window (window event-window)) (card16 width height)) (declare-event :configure-request (card16 sequence) (window (parent event-window) window) (int16 x y) (card16 width height border-width) ((member :above :below :top-if :bottom-if :opposite) stack-mode) ((or null window) above-sibling) (mask16 value-mask)) (declare-event :circulate-notify (card16 sequence) (window event-window window) ((member :top :bottom) place)) (declare-event :circulate-request (card16 sequence) (window (parent event-window) window) ((member :top :bottom) place)) (declare-event :property-notify (card16 sequence) (window (window event-window)) (keyword atom) ((member :new-value :deleted) state) ((or null card32) time)) (declare-event :selection-clear (card16 sequence) (window (window event-window)) (keyword selection) ((or null card32) time)) (declare-event :selection-request (card16 sequence) (window (window event-window) requestor) (keyword selection target) ((or null keyword) property) ((or null card32) time)) (declare-event :selection-notify (card16 sequence) (window (window event-window)) (keyword selection target) ((or null keyword) property) ((or null card32) time)) (declare-event :colormap-notify (card16 sequence) (window (window event-window)) ((or null colormap) colormap) (boolean new-p installed-p)) (declare-event :mapping-notify (card16 sequence) ((member :modifier :keyboard :pointer) request) (card8 start count)) (declare-event :client-message (card16 sequence) (window (window event-window)) ((member 8 16 32) format) (sequence data)) (defun queue-event (display event-key &rest args &key append-p &allow-other-keys) ;; The event is put at the head of the queue if append-p is nil, else the tail. ;; Additional arguments depend on event-key, and are as specified above with ;; declare-event, except that both resource-ids and resource objects are accepted ;; in the event components. (declare (type display display) (type event-key event-key) (type boolean append-p))) ;;; From here on, there has been less coherent review of the interface: ;;;----------------------------------------------------------------------------- ;;; Window Manager Property functions (defun wm-name (window) (declare (type window window) (clx-values string))) (defsetf wm-name (window) (name)) (defun wm-icon-name (window) (declare (type window window) (clx-values string))) (defsetf wm-icon-name (window) (name)) (defun get-wm-class (window) (declare (type window window) (clx-values (or null name-string) (or null class-string)))) (defun set-wm-class (window resource-name resource-class) (declare (type window window) (type (or null stringable) resource-name resource-class))) (defun wm-command (window) ;; Returns a list whose car is a command string and ;; whose cdr is the list of argument strings. (declare (type window window) (clx-values (clx-list string)))) (defsetf wm-command (window) (command) ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or ;; equivalent), with elements of command separated by NULL characters. This ;; enables ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) ;; to recover a lisp command. (declare (type window window) (type (clx-list stringable) command))) (defun wm-client-machine (window) ;; Returns a list whose car is a command string and ;; whose cdr is the list of argument strings. (declare (type window window) (clx-values string))) (defsetf wm-client-machine (window) (string) (declare (type window window) (type stringable string))) (defstruct wm-hints (input nil :type (or null (member :off :on))) (initial-state nil :type (or null (member :normal :iconic))) (icon-pixmap nil :type (or null pixmap)) (icon-window nil :type (or null window)) (icon-x nil :type (or null card16)) (icon-y nil :type (or null card16)) (icon-mask nil :type (or null pixmap)) (window-group nil :type (or null resource-id)) (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field ;; may be extended in the future ) (defun wm-hints (window) (declare (type window window) (clx-values wm-hints))) (defsetf wm-hints (window) (wm-hints)) (defstruct wm-size-hints ;; Defaulted T to put the burden of remembering these on widget programmers. (user-specified-position-p t :type boolean) ;; True when user specified x y (user-specified-size-p t :type boolean) ;; True when user specified width height (x nil :type (or null int16)) ;; Obsolete (y nil :type (or null int16)) ;; Obsolete (width nil :type (or null card16)) ;; Obsolete (height nil :type (or null card16)) ;; Obsolete (min-width nil :type (or null card16)) (min-height nil :type (or null card16)) (max-width nil :type (or null card16)) (max-height nil :type (or null card16)) (width-inc nil :type (or null card16)) (height-inc nil :type (or null card16)) (min-aspect nil :type (or null number)) (max-aspect nil :type (or null number)) (base-width nil :type (or null card16)) (base-height nil :type (or null card16)) (win-gravity nil :type (or null win-gravity))) (defun wm-normal-hints (window) (declare (type window window) (clx-values wm-size-hints))) (defsetf wm-normal-hints (window) (wm-size-hints)) ;; ICON-SIZES uses the SIZE-HINTS structure (defun icon-sizes (window) (declare (type window window) (clx-values wm-size-hints))) (defsetf icon-sizes (window) (wm-size-hints)) (defun wm-protocols (window) (declare (type window window) (clx-values protocols))) (defsetf wm-protocols (window) (protocols) (declare (type window window) (type (clx-list keyword) protocols))) (defun wm-colormap-windows (window) (declare (type window window) (clx-values windows))) (defsetf wm-colormap-windows (window) (windows) (declare (type window window) (type (clx-list window) windows))) (defun transient-for (window) (declare (type window window) (clx-values window))) (defsetf transient-for (window) (transient) (declare (type window window transient))) (defun set-wm-properties (window &rest options &key name icon-name resource-name resource-class command hints normal-hints ;; the following are used for wm-normal-hints user-specified-position-p user-specified-size-p program-specified-position-p program-specified-size-p min-width min-height max-width max-height width-inc height-inc min-aspect max-aspect base-width base-height win-gravity ;; the following are used for wm-hints input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group) ;; Set properties for WINDOW. (declare (type window window) (type (or null stringable) name icoin-name resource-name resource-class) (type (or null list) command) (type (or null wm-hints) hints) (type (or null wm-size-hints) normal-hints) (type boolean user-specified-position-p user-specified-size-p) (type boolean program-specified-position-p program-specified-size-p) (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity) (type (or null number) min-aspect max-aspect) (type (or null (member :off :on)) input) (type (or null (member :normal :iconic)) initial-state) (type (or null pixmap) icon-pixmap icon-mask) (type (or null window) icon-window) (type (or null card16) icon-x icon-y) (type (or null resource-id) window-group))) (defun iconify-window (window) (declare (type window window))) (defun withdraw-window (window) (declare (type window window))) (defstruct standard-colormap (colormap nil :type (or null colormap)) (base-pixel 0 :type pixel) (max-color nil :type (or null color)) (mult-color nil :type (or null color)) (visual nil :type (or null visual-info)) (kill nil :type (or (member nil :release-by-freeing-colormap) drawable gcontext cursor colormap font))) (defun rgb-colormaps (window property) (declare (type window window) (type (member :rgb_default_map :rgb_best_map :rgb_red_map :rgb_green_map :rgb_blue_map) property) (clx-values (clx-list standard-colormap)))) (defsetf rgb-colormaps (window property) (standard-colormaps) (declare (type window window) (type (member :rgb_default_map :rgb_best_map :rgb_red_map :rgb_green_map :rgb_blue_map) property) (type (clx-list standard-colormap) standard-colormaps))) (defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string) (transform #'card8->char) (start 0) end) ;; Return the contents of cut-buffer BUFFER (declare (type display display) (type (integer 0 7) buffer) (type xatom type) (type array-index start) (type (or null array-index) end) (type t result-type) ;a sequence type (type (or null (function (integer) t)) transform) (clx-values sequence type format bytes-after))) (defsetf cut-buffer (display buffer &key (type :string) (format 8) (transform #'char->card8) (start 0) end) (data)) (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) ;; Positive rotates left, negative rotates right (opposite of actual ;; protocol request). When careful-p, ensure all cut-buffer ;; properties are defined, to prevent errors. (declare (type display display) (type int16 delta) (type boolean careful-p))) ;;;----------------------------------------------------------------------------- ;;; Keycode mapping (defun define-keysym-set (set first-keysym last-keysym) ;; Define all keysyms from first-keysym up to and including ;; last-keysym to be in SET (returned from the keysym-set function). ;; Signals an error if the keysym range overlaps an existing set. (declare (type keyword set) (type keysym first-keysym last-keysym))) (defun keysym-set (keysym) ;; Return the character code set name of keysym ;; Note that the keyboard set (255) has been broken up into its parts. (declare (type keysym keysym) (clx-values keyword))) (defun define-keysym (object keysym &key lowercase translate modifiers mask display) ;; Define the translation from keysym/modifiers to a (usually ;; character) object. ANy previous keysym definition with ;; KEYSYM and MODIFIERS is deleted before adding the new definition. ;; ;; MODIFIERS is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying when to use this ;; keysym-translation. The default is NIL. ;; ;; MASK is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying which modifiers to look at ;; (i.e. modifiers not specified are don't-cares). ;; If mask is :MODIFIERS then the mask is the same as the modifiers ;; (i.e. modifiers not specified by modifiers are don't cares) ;; The default mask is *default-keysym-translate-mask* ;; ;; If DISPLAY is specified, the translation will be local to DISPLAY, ;; otherwise it will be the default translation for all displays. ;; ;; LOWERCASE is used for uppercase alphabetic keysyms. The value ;; is the associated lowercase keysym. This information is used ;; by the keysym-both-case-p predicate (for caps-lock computations) ;; and by the keysym-downcase function. ;; ;; TRANSLATE will be called with parameters (display state OBJECT) ;; when translating KEYSYM and modifiers and mask are satisfied. ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) ;; (or modifiers 0))) ;; when mask and modifiers aren't lists of keysyms] ;; The default is #'default-keysym-translate ;; (declare (type (or base-char t) object) (type keysym keysym) (type (or null mask16 (clx-list (or keysym state-mask-key))) modifiers) (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) mask) (type (or null display) display) (type (or null keysym) lowercase) (type (function (display card16 t) t) translate))) (defvar *default-keysym-translate-mask* (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) (logand #xff (lognot (make-state-mask :lock)))) "Default keysym state mask to use during keysym-translation.") (defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. (declare (type (or base-char t) object) (type keysym keysym) (type (or null mask16 (clx-list (or keysym state-mask-key))) modifiers) (type (or null display) display))) (defun default-keysym-translate (display state object) ;; If object is a character, char-bits are set from state. ;; If object is a list, it is an alist with entries: ;; (base-char [modifiers] [mask-modifiers) ;; When MODIFIERS are specified, this character translation ;; will only take effect when the specified modifiers are pressed. ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore. ;; When MASK-MODIFIERS is missing, all other modifiers are ignored. ;; In ambiguous cases, the most specific translation is used. (declare (type display display) (type card16 state) (type t object) (clx-values t))) ;; Object returned by keycode->character (defmacro keysym (keysym &rest bytes) ;; Build a keysym. ;; If KEYSYM is an integer, it is used as the most significant bits of ;; the keysym, and BYTES are used to specify low order bytes. The last ;; parameter is always byte4 of the keysym. If KEYSYM is not an ;; integer, the keysym associated with KEYSYM is returned. ;; ;; This is a macro and not a function macro to promote compile-time ;; lookup. All arguments are evaluated. (declare (type t keysym) (type (clx-list card8) bytes) (clx-values keysym))) (defun character->keysyms (character &optional display) ;; Given a character, return a list of all matching keysyms. ;; If DISPLAY is given, translations specific to DISPLAY are used, ;; otherwise only global translations are used. ;; Implementation dependent function. ;; May be slow [i.e. do a linear search over all known keysyms] (declare (type t character) (type (or null display) display) (clx-values (clx-list keysym)))) (defun keycode->keysym (display keycode keysym-index) (declare (type display display) (type card8 code) (type card16 state) (type card8 keysym-index) (clx-values keysym))) (defun keysym->keycodes (display keysym) ;; Return keycodes for keysym, as multiple values (declare (type display display) (type keysym keysym) (clx-values (or null keycode) (or null keycode) (or null keycode))) ) (defun keysym->character (display keysym &optional state) ;; Find the character associated with a keysym. ;; STATE is used for adding char-bits to character as follows: ;; control -> char-control-bit ;; mod-1 -> char-meta-bit ;; mod-2 -> char-super-bit ;; mod-3 -> char-hyper-bit ;; Implementation dependent function. (declare (type display display) (type keysym keysym) (type (or null card16) state) (clx-values (or null character)))) (defun keycode->character (display keycode state &key keysym-index (keysym-index-function #'default-keysym-index)) ;; keysym-index defaults to the result of keysym-index-function which ;; is called with the following parameters: ;; (char0 state caps-lock-p keysyms-per-keycode) ;; where char0 is the "character" object associated with keysym-index 0 and ;; caps-lock-p is non-nil when the keysym associated with the lock ;; modifier is for caps-lock. ;; STATE is also used for setting char-bits: ;; control -> char-control-bit ;; mod-1 -> char-meta-bit ;; mod-2 -> char-super-bit ;; mod-3 -> char-hyper-bit ;; Implementation dependent function. (declare (type display display) (type card8 keycode) (type card16 state) (type (or null card8) keysym-index) (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8)) keysym-index-function) (clx-values (or null character)))) (defun default-keysym-index (display keycode state) ;; Returns a keysym-index for use with keycode->character (declare (clx-values card8)) ) ;;; default-keysym-index implements the following tables: ;;; ;;; control shift caps-lock character character ;;; 0 0 0 #\a #\8 ;;; 0 0 1 #\A #\8 ;;; 0 1 0 #\A #\* ;;; 0 1 1 #\A #\* ;;; 1 0 0 #\control-A #\control-8 ;;; 1 0 1 #\control-A #\control-8 ;;; 1 1 0 #\control-shift-a #\control-* ;;; 1 1 1 #\control-shift-a #\control-* ;;; ;;; control shift shift-lock character character ;;; 0 0 0 #\a #\8 ;;; 0 0 1 #\A #\* ;;; 0 1 0 #\A #\* ;;; 0 1 1 #\A #\8 ;;; 1 0 0 #\control-A #\control-8 ;;; 1 0 1 #\control-A #\control-* ;;; 1 1 0 #\control-shift-a #\control-* ;;; 1 1 1 #\control-shift-a #\control-8 (defun state-keysymp (display state keysym) ;; Returns T when a modifier key associated with KEYSYM is on in STATE (declare (type display display) (type card16 state) (type keysym keysym) (clx-values boolean))) (defun mapping-notify (display request start count) ;; Called on a mapping-notify event to update ;; the keyboard-mapping cache in DISPLAY (declare (type display display) (type (member :modifier :keyboard :pointer) request) (type card8 start count))) (defun keysym-in-map-p (display keysym keymap) ;; Returns T if keysym is found in keymap (declare (type display display) (type keysym keysym) (type (bit-vector 256) keymap) (value boolean))) (defun character-in-map-p (display character keymap) ;; Implementation dependent function. ;; Returns T if character is found in keymap (declare (type display display) (type t character) (type (bit-vector 256) keymap) (value boolean))) ;;;----------------------------------------------------------------------------- ;;; Extensions (defmacro define-extension (name &key events errors) ;; Define extension NAME with EVENTS and ERRORS. ;; Note: The case of NAME is important. ;; To define the request, Use: ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) ;; See the REQUESTS file for lots of examples. ;; To define event handlers, use declare-event. ;; To define error handlers, use declare-error and define-condition. (declare (type stringable name) (type (clx-list symbol) events errors))) (defmacro extension-opcode (display name) ;; Returns the major opcode for extension NAME. ;; This is a macro to enable NAME to be interned for fast run-time ;; retrieval. ;; Note: The case of NAME is important. (declare (type display display) (type stringable name) (clx-values card8))) (defmacro define-error (error-key function) ;; Associate a function with ERROR-KEY which will be called with ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of ;; keyword/value pairs which will be passed on to the error handler. ;; A compiler warning is printed when ERROR-KEY is not defined in a ;; preceding DEFINE-EXTENSION. ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type ;; macros for getting error fields. See DECODE-CORE-ERROR for ; an example. (declare (type symbol error-key) (type function function))) ;; All core errors use this, so we make it available to extensions. (defun decode-core-error (display event &optional arg) ;; All core errors have the following keyword/argument pairs: ;; :major integer ;; :minor integer ;; :sequence integer ;; :current-sequence integer ;; In addition, many have an additional argument that comes from the ;; same place in the event, but is named differently. When the ARG ;; argument is specified, the keyword ARG with card32 value starting ;; at byte 4 of the event is returned with the other keyword/argument ;; pairs. (declare (type display display) (type reply-buffer event) (type (or null keyword) arg) (clx-values keyword/arg-plist))) ;; This isn't new, just extended. (defmacro declare-event (event-codes &body declares) ;; Used to indicate the keyword arguments for handler functions in ;; process-event and event-case. ;; Generates functions used in SEND-EVENT. ;; A compiler warning is printed when all of EVENT-CODES are not ;; defined by a preceding DEFINE-EXTENSION. ;; See the INPUT file for lots of examples. (declare (type (or keyword (clx-list keywords)) event-codes) (type (alist (field-type symbol) (field-names (clx-list symbol))) declares))) (defmacro define-gcontext-accessor (name &key default set-function copy-function) ;; This will define a new gcontext accessor called NAME. ;; Defines the gcontext-NAME accessor function and its defsetf. ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when ;; gcontext-cache-p is true. The NAME keyword will be allowed in ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) ;; from create-gcontext, and force-gcontext-changes. ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) ;; from copy-gcontext and copy-gcontext-components. ;; The copy-function defaults to: ;; (lambda (ignore dst-gc value) ;; (if value ;; (,set-function dst-gc value) ;; (error "Can't copy unknown GContext component ~a" ',name))) (declare (type symbol name) (type t default) (type symbol set-function) ;; required (type symbol copy-function))) ;; To aid extension implementors in attaching additional information to ;; clx data structures, the following accessors (with SETF's) are ;; defined. GETF can be used on these to extend the structures. display-plist screen-plist visual-info-plist gcontext-plist font-plist drawable-plist ;;; These have had perhaps even less review. ;;; Add some of the functionality provided by the C XLIB library. ;;; ;;; LaMott G. Oren, Texas Instruments 10/87 ;;; ;;; Design Contributors: ;;; Robert W. Scheifler, MIT ;;;----------------------------------------------------------------------------- ;;; Regions (not yet implemented) ;;; Regions are arbitrary collections of pixels. This is represented ;;; in the region structure as either a list of rectangles or a bitmap. (defun make-region (&optional x y width height) ;; With no parameters, returns an empty region ;; If some parameters are given, all must be given. (declare (type (or null int16) x y width height) (clx-values region))) (defun region-p (thing)) (defun copy-region (region)) (defun region-empty-p (region) (declare (type region region) (clx-values boolean))) (defun region-clip-box (region) ;; Returns a region which is the smallest enclosing rectangle ;; enclosing REGION (declare (type region region) (clx-values region))) ;; Accessors that return the boundaries of a region (defun region-x (region)) (defun region-y (region)) (defun region-width (region)) (defun region-height (region)) (defsetf region-x (region) (x)) (defsetf region-y (region) (y)) ;; Setting a region's X/Y translates the region (defun region-intersection (&rest regions) "Returns a region which is the intersection of one or more REGIONS. Returns an empty region if the intersection is empty. If there are no regions given, return a very large region." (declare (type (clx-list region) regions) (clx-values region))) (defun region-union (&rest regions) "Returns a region which is the union of a number of REGIONS (i.e. the smallest region that can contain all the other regions) Returns the empty region if no regions are given." (declare (type (clx-list region) regions) (clx-values region))) (defun region-subtract (region subtract) "Returns a region containing the points that are in REGION but not in SUBTRACT" (declare (type region region subtract) (clx-values region))) (defun point-in-region-p (region x y) ;; Returns T when X/Y are a point within REGION. (declare (type region region) (type int16 x y) (clx-values boolean))) (defun region-equal (a b) ;; Returns T when regions a and b contain the same points. ;; That is, return t when for every X/Y (point-in-region-p a x y) ;; equals (point-in-region-p b x y) (declare (type region a b) (clx-values boolean))) (defun subregion-p (large small) "Returns T if SMALL is within LARGE. That is, return T when for every X/Y (point-in-region-p small X Y) implies (point-in-region-p large X Y)." (declare (type region large small) (clx-values boolean))) (defun region-intersect-p (a b) "Returns T if A intersects B. That is, return T when there is some point common to regions A and B." (declare (type region a b) (clx-values boolean))) (defun map-region (region function &rest args) ;; Calls function with arguments (x y . args) for every point in REGION. (declare (type region region) (type (function x y &rest args) function))) ;; Why isn't it better to augment ;; gcontext-clip-mask to deal with ;; (or null (member :none) pixmap rect-seq region) ;; and force conversions on the caller? ;; Good idea. ;;(defun gcontext-clip-region (gcontext) ;; ;; If the clip-mask of GCONTEXT is known, return it as a region. ;; (declare (type gcontext gcontext) ;; (clx-values (or null region)))) ;;(defsetf gcontext-clip-region (gcontext) (region) ;; ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include ;; ;; only the pixels within REGION. ;; (declare (type gcontext gcontext) ;; (type region region))) (defun image->region (image) ;; Returns a region containing the 1 bits of a depth-1 image ;; Signals an error if image isn't of depth 1. (declare (type image image) (clx-values region))) (defun region->image (region) ;; Returns a depth-1 image containg 1 bits for every pixel in REGION. (declare (type region region) (clx-values image))) (defun polygon-region (points &optional (fill-rule :even-odd)) (declare (type sequence points) ;(repeat-seq (integer x) (integer y)) (type (member :even-odd :winding) fill-rule) (clx-values region))) ;;;----------------------------------------------------------------------------- ;;; IMAGE functions (deftype bitmap () '(array bit (* *))) (deftype pixarray () '(array pixel (* *))) (defconstant *lisp-byte-lsb-first-p* #+lispm t #-lispm nil "Byte order in pixel arrays") (defstruct image ;; Public structure (width 0 :type card16 :read-only t) (height 0 :type card16 :read-only t) (depth 1 :type card8 :read-only t) (plist nil :type list)) ;; Image-Plist accessors: (defun image-name (image)) (defun image-x-hot (image)) (defun image-y-hot (image)) (defun image-red-mask (image)) (defun image-blue-mask (image)) (defun image-green-mask (image)) (defsetf image-name (image) (name)) (defsetf image-x-hot (image) (x)) (defsetf image-y-hot (image) (y)) (defsetf image-red-mask (image) (mask)) (defsetf image-blue-mask (image) (mask)) (defsetf image-green-mask (image) (mask)) (defstruct (image-x (:include image)) ;; Use this format for shoveling image data ;; Private structure. Accessors for these NOT exported. (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) (bytes-per-line 0 :type card16) (scanline-pad 32 :type (member 8 16 32)) (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) (bit-lsb-first-p nil :type boolean) ; Bit order (byte-lsb-first-p nil :type boolean) ; Byte order (data #() :type (array card8 (*)))) ; row-major (defstruct (image-xy (:include image)) ;; Public structure ;; Use this format for image processing (bitmap-list nil :type (clx-list bitmap))) (defstruct (image-z (:include image)) ;; Public structure ;; Use this format for image processing (bits-per-pixel 0 :type (member 1 4 8 16 24 32)) (pixarray #() :type pixarray)) (defun create-image (&key (width (required-arg width)) (height (required-arg height)) depth data plist name x-hot y-hot red-mask blue-mask green-mask bits-per-pixel format scanline-pad bytes-per-line byte-lsb-first-p bit-lsb-first-p ) ;; Returns an image-x image-xy or image-z structure, depending on the ;; type of the :DATA parameter. (declare (type card16 width height) ; Required (type (or null card8) depth) ; Defualts to 1 (type (or (array card8 (*)) ;Returns image-x (clx-list bitmap) ;Returns image-xy pixarray) data) ;Returns image-z (type list plist) (type (or null stringable) name) (type (or null card16) x-hot y-hot) (type (or null pixel) red-mask blue-mask green-mask) (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) ;; The following parameters are ignored for image-xy and image-z: (type (or null (member :bitmap :xy-pixmap :z-pixmap)) format) ; defaults to :z-pixmap (type (or null (member 8 16 32)) scanline-pad) (type (or null card16) bytes-per-line) ;default from width and scanline-pad (type boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image))) (defun get-image (drawable &key (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) plane-mask format result-type) ;; Get an image from the server. ;; Format defaults to :z-pixmap. Result-Type defaults from Format, ;; image-z for :z-pixmap, and image-xy for :xy-pixmap. ;; Plane-mask defaults to #xFFFFFFFF. ;; Returns an image-x image-xy or image-z structure, depending on the ;; result-type parameter. (declare (type drawable drawable) (type int16 x y) ;; required (type card16 width height) ;; required (type (or null pixel) plane-mask) (type (or null (member :xy-pixmap :z-pixmap)) format) (type (or null (member image-x image-xy image-z)) result-type) (clx-values image))) (defun put-image (drawable gcontext image &key (src-x 0) (src-y 0) (x (required-arg x)) (y (required-arg y)) width height bitmap-p) ;; When BITMAP-P, force format to be :bitmap when depth=1 ;; This causes gcontext to supply foreground & background pixels. (declare (type drawable drawable) (type gcontext gcontext) (type image image) (type int16 x y) ;; required (type (or null card16) width height) (type boolean bitmap-p))) (defun copy-image (image &key (x 0) (y 0) width height result-type) ;; Copy with optional sub-imaging and format conversion. ;; result-type defaults to (type-of image) (declare (type image image) (type card16 x y) (type (or null card16) width height) ;; Default from image (type (or null (member image-x image-xy image-z)) result-type) (clx-values image))) (defun read-bitmap-file (pathname) ;; Creates an image from a C include file in standard X11 format (declare (type (or pathname string stream) pathname) (clx-values image))) (defun write-bitmap-file (pathname image &optional name) ;; Writes an image to a C include file in standard X11 format ;; NAME argument used for variable prefixes. Defaults to "image" (declare (type (or pathname string stream) pathname) (type image image) (type (or null stringable) name))) ;;;----------------------------------------------------------------------------- ;;; Resource data-base (defun make-resource-database () ;; Returns an empty resource data-base (declare (clx-values resource-database))) (defun get-resource (database value-name value-class full-name full-class) ;; Return the value of the resource in DATABASE whose partial name ;; most closely matches (append full-name (list value-name)) and ;; (append full-class (list value-class)). (declare (type resource-database database) (type stringable value-name value-class) (type (clx-list stringable) full-name full-class) (clx-values value))) (defun add-resource (database name-list value) ;; name-list is a list of either strings or symbols. If a symbol, ;; case-insensitive comparisons will be used, if a string, ;; case-sensitive comparisons will be used. The symbol '* or ;; string "*" are used as wildcards, matching anything or nothing. (declare (type resource-database database) (type (clx-list stringable) name-list) (type t value))) (defun delete-resource (database name-list) (declare (type resource-database database) (type (clx-list stringable) name-list))) (defun map-resource (database function &rest args) ;; Call FUNCTION on each resource in DATABASE. ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function ((clx-list stringable) t &rest t) t) function) (clx-values nil))) (defun merge-resources (database with-database) (declare (type resource-database database with-database) (clx-values resource-database)) (map-resource #'add-resource database with-database) with-database) ;; Note: with-input-from-string can be used with read-resources to define ;; default resources in a program file. (defun read-resources (database pathname &key key test test-not) ;; Merges resources from a file in standard X11 format with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string) t)) key) (type (or null (function ((clx-list string) t) boolean)) test test-not) (clx-values resource-database))) (defun write-resources (database pathname &key write test test-not) ;; Write resources to PATHNAME in the standard X11 format. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string stream) t)) write) (type (or null (function ((clx-list string) t) boolean)) test test-not))) (defun root-resources (screen &key database key test test-not) "Returns a resource database containing the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. If an existing DATABASE is given, then resource values are merged with the DATABASE and the modified DATABASE is returned. TEST and TEST-NOT are predicates for selecting which resources are read. Arguments are a resource name list and a resource value. The KEY function, if given, is called to convert a resource value string to the value given to TEST or TEST-NOT." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (string) t)) key) (type (or null (function list boolean)) test test-not) (clx-values resource-database))) (defsetf root-resources (screen &key test test-not (write 'princ)) (database) "Changes the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. TEST and TEST-NOT are predicates for selecting which resources from the DATABASE are written. Arguments are a resource name list and a resource value. The WRITE function is used to convert a resource value into a string stored in the property." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function list boolean)) test test-not) (type (or null (function (string stream) t)) write) (clx-values resource-database))) ;;;----------------------------------------------------------------------------- ;;; Shared GContext's (defmacro using-gcontext ((var &rest options &key drawable function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes) &body body) ;; Equivalent to (let ((var (apply #'make-gcontext options))) ,@body) ;; but more efficient because it uses a gcontext cache associated with ;; drawable's display. ) X11 Request Name CLX Function Name ----------------- ----------------- AllocColor ALLOC-COLOR AllocColorCells ALLOC-COLOR-CELLS AllocColorPlanes ALLOC-COLOR-PLANES AllocNamedColor ALLOC-COLOR AllowEvents ALLOW-EVENTS Bell BELL ChangeAccessControl (setf (ACCESS-CONTROL display) boolean) ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB ChangeCloseDownMode (setf (CLOSE-DOWN-MODE display) mode) ChangeGC FORCE-GCONTEXT-CHANGES ;; See WITH-GCONTEXT (setf (gcontext-function gc) boole-constant) (setf (gcontext-plane-mask gc) card32) (setf (gcontext-foreground gc) card32) (setf (gcontext-background gc) card32) (setf (gcontext-line-width gc) card16) (setf (gcontext-line-style gc) keyword) (setf (gcontext-cap-style gc) keyword) (setf (gcontext-join-style gc) keyword) (setf (gcontext-fill-style gc) keyword) (setf (gcontext-fill-rule gc) keyword) (setf (gcontext-tile gc) pixmap) (setf (gcontext-stipple gc) pixmap) (setf (gcontext-ts-x gc) int16) ;; Tile-Stipple-X-origin (setf (gcontext-ts-y gc) int16) ;; Tile-Stipple-Y-origin (setf (gcontext-font gc &optional metrics-p) font) (setf (gcontext-subwindow-mode gc) keyword) (setf (gcontext-exposures gc) (member :on :off)) (setf (gcontext-clip-x gc) int16) (setf (gcontext-clip-y gc) int16) (setf (gcontext-clip-mask gc &optional ordering) (or (member :none) pixmap rect-seq)) (setf (gcontext-dash-offset gc) card16) (setf (gcontext-dashes gc) (or card8 sequence)) (setf (gcontext-arc-mode gc) (member :chord :pie-slice)) (setf (gcontext-clip-ordering gc) keyword) ChangeHosts ADD-ACCESS-HOST ChangeHosts REMOVE-ACCESS-HOST ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL ChangePointerControl CHANGE-POINTER-CONTROL ChangeProperty CHANGE-PROPERTY ChangeSaveSet REMOVE-FROM-SAVE-SET ChangeSaveSet ADD-TO-SAVE-SET ChangeWindowAttributes ;; See WITH-STATE (setf (window-background window) value) (setf (window-border window) value) (setf (window-bit-gravity window) value) (setf (window-gravity window) value) (setf (window-backing-store window) value) (setf (window-backing-planes window) value) (setf (window-backing-pixel window) value) (setf (window-override-redirect window) value) (setf (window-save-under window) value) (setf (window-colormap window) value) (setf (window-cursor window) value) (setf (window-event-mask window) value) (setf (window-do-not-propagate-mask window) value) CirculateWindow CIRCULATE-WINDOW-DOWN CirculateWindow CIRCULATE-WINDOW-UP ClearToBackground CLEAR-AREA CloseFont CLOSE-FONT ConfigureWindow ;; See WITH-STATE (setf (drawable-x drawable) integer) (setf (drawable-y drawable) integer) (setf (drawable-width drawable) integer) (setf (drawable-height drawable) integer) (setf (drawable-depth drawable) integer) (setf (drawable-border-width drawable) integer) (setf (window-priority window &optional sibling) integer) ConvertSelection CONVERT-SELECTION CopyArea COPY-AREA CopyColormapAndFree COPY-COLORMAP-AND-FREE CopyGC COPY-GCONTEXT CopyGC COPY-GCONTEXT-COMPONENTS CopyPlane COPY-PLANE CreateColormap CREATE-COLORMAP CreateCursor CREATE-CURSOR CreateGC CREATE-GCONTEXT CreateGlyphCursor CREATE-GLYPH-CURSOR CreatePixmap CREATE-PIXMAP CreateWindow CREATE-WINDOW DeleteProperty DELETE-PROPERTY DestroySubwindows DESTROY-SUBWINDOWS DestroyWindow DESTROY-WINDOW FillPoly DRAW-LINES ForceScreenSaver RESET-SCREEN-SAVER ForceScreenSaver ACTIVATE-SCREEN-SAVER FreeColormap FREE-COLORMAP FreeColors FREE-COLORS FreeCursor FREE-CURSOR FreeGC FREE-GCONTEXT FreePixmap FREE-PIXMAP GetAtomName ATOM-NAME GetFontPath FONT-PATH GetGeometry ;; See WITH-STATE DRAWABLE-ROOT DRAWABLE-X DRAWABLE-Y DRAWABLE-WIDTH DRAWABLE-HEIGHT DRAWABLE-DEPTH DRAWABLE-BORDER-WIDTH GetImage GET-RAW-IMAGE GetInputFocus INPUT-FOCUS GetKeyboardControl KEYBOARD-CONTROL GetKeyboardMapping KEYBOARD-MAPPING GetModifierMapping MODIFIER-MAPPING GetMotionEvents MOTION-EVENTS GetPointerControl POINTER-CONTROL GetPointerMapping POINTER-MAPPING GetProperty GET-PROPERTY GetScreenSaver SCREEN-SAVER GetSelectionOwner SELECTION-OWNER GetWindowAttributes ;; See WITH-STATE WINDOW-VISUAL-INFO WINDOW-CLASS WINDOW-BIT-GRAVITY WINDOW-GRAVITY WINDOW-BACKING-STORE WINDOW-BACKING-PLANES WINDOW-BACKING-PIXEL WINDOW-SAVE-UNDER WINDOW-OVERRIDE-REDIRECT WINDOW-EVENT-MASK WINDOW-DO-NOT-PROPAGATE-MASK WINDOW-COLORMAP WINDOW-COLORMAP-INSTALLED-P WINDOW-ALL-EVENT-MASKS WINDOW-MAP-STATE GrabButton GRAB-BUTTON GrabKey GRAB-KEY GrabKeyboard GRAB-KEYBOARD GrabPointer GRAB-POINTER GrabServer GRAB-SERVER ImageText16 DRAW-IMAGE-GLYPHS ImageText16 DRAW-IMAGE-GLYPH ImageText8 DRAW-IMAGE-GLYPHS InstallColormap INSTALL-COLORMAP InternAtom FIND-ATOM InternAtom INTERN-ATOM KillClient KILL-TEMPORARY-CLIENTS KillClient KILL-CLIENT ListExtensions LIST-EXTENSIONS ListFonts LIST-FONT-NAMES ListFontsWithInfo LIST-FONTS ListHosts ACCESS-CONTROL ListHosts ACCESS-HOSTS ListInstalledColormaps INSTALLED-COLORMAPS ListProperties LIST-PROPERTIES LookupColor LOOKUP-COLOR MapSubwindows MAP-SUBWINDOWS MapWindow MAP-WINDOW OpenFont OPEN-FONT PolyArc DRAW-ARC PolyArc DRAW-ARCS PolyFillArc DRAW-ARC PolyFillArc DRAW-ARCS PolyFillRectangle DRAW-RECTANGLE PolyFillRectangle DRAW-RECTANGLES PolyLine DRAW-LINE PolyLine DRAW-LINES PolyPoint DRAW-POINT PolyPoint DRAW-POINTS PolyRectangle DRAW-RECTANGLE PolyRectangle DRAW-RECTANGLES PolySegment DRAW-SEGMENTS PolyText16 DRAW-GLYPH PolyText16 DRAW-GLYPHS PolyText8 DRAW-GLYPHS PutImage PUT-RAW-IMAGE QueryBestSize QUERY-BEST-CURSOR QueryBestSize QUERY-BEST-STIPPLE QueryBestSize QUERY-BEST-TILE QueryColors QUERY-COLORS QueryExtension QUERY-EXTENSION QueryFont FONT-NAME FONT-NAME FONT-DIRECTION FONT-MIN-CHAR FONT-MAX-CHAR FONT-MIN-BYTE1 FONT-MAX-BYTE1 FONT-MIN-BYTE2 FONT-MAX-BYTE2 FONT-ALL-CHARS-EXIST-P FONT-DEFAULT-CHAR FONT-ASCENT FONT-DESCENT FONT-PROPERTIES FONT-PROPERTY CHAR-LEFT-BEARING CHAR-RIGHT-BEARING CHAR-WIDTH CHAR-ASCENT CHAR-DESCENT CHAR-ATTRIBUTES MIN-CHAR-LEFT-BEARING MIN-CHAR-RIGHT-BEARING MIN-CHAR-WIDTH MIN-CHAR-ASCENT MIN-CHAR-DESCENT MIN-CHAR-ATTRIBUTES MAX-CHAR-LEFT-BEARING MAX-CHAR-RIGHT-BEARING MAX-CHAR-WIDTH MAX-CHAR-ASCENT MAX-CHAR-DESCENT MAX-CHAR-ATTRIBUTES QueryKeymap QUERY-KEYMAP QueryPointer GLOBAL-POINTER-POSITION QueryPointer POINTER-POSITION QueryPointer QUERY-POINTER QueryTextExtents TEXT-EXTENTS QueryTextExtents TEXT-WIDTH QueryTree QUERY-TREE RecolorCursor RECOLOR-CURSOR ReparentWindow REPARENT-WINDOW RotateProperties ROTATE-PROPERTIES SendEvent SEND-EVENT SetClipRectangles FORCE-GCONTEXT-CHANGES ;; See WITH-GCONTEXT (setf (gcontext-clip-x gc) int16) (setf (gcontext-clip-y gc) int16) (setf (gcontext-clip-mask gc &optional ordering) (or (member :none) pixmap rect-seq)) (setf (gcontext-clip-ordering gc) keyword) SetDashes FORCE-GCONTEXT-CHANGES ;; See WITH-GCONTEXT (setf (gcontext-dash-offset gc) card16) (setf (gcontext-dashes gc) (or card8 sequence)) SetFontPath (setf (font-path font) paths) Where paths is (type (clx-sequence (or string pathname))) SetInputFocus SET-INPUT-FOCUS SetKeyboardMapping CHANGE-KEYBOARD-MAPPING SetModifierMapping SET-MODIFIER-MAPPING SetPointerMapping SET-POINTER-MAPPING SetScreenSaver SET-SCREEN-SAVER SetSelectionOwner SET-SELECTION-OWNER StoreColors STORE-COLOR StoreColors STORE-COLORS StoreNamedColor STORE-COLOR StoreNamedColor STORE-COLORS TranslateCoords TRANSLATE-COORDINATES UngrabButton UNGRAB-BUTTON UngrabKey UNGRAB-KEY UngrabKeyboard UNGRAB-KEYBOARD UngrabPointer UNGRAB-POINTER UngrabServer UNGRAB-SERVER UninstallColormap UNINSTALL-COLORMAP UnmapSubwindows UNMAP-SUBWINDOWS UnmapWindow UNMAP-WINDOW WarpPointer WARP-POINTER WarpPointer WARP-POINTER-IF-INSIDE WarpPointer WARP-POINTER-RELATIVE WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE NoOperation NO-OPERATION X11 Request Name CLX Function Name ----------------- ----------------- ListHosts ACCESS-CONTROL ListHosts ACCESS-HOSTS ForceScreenSaver ACTIVATE-SCREEN-SAVER ChangeHosts ADD-ACCESS-HOST ChangeSaveSet ADD-TO-SAVE-SET AllocColor ALLOC-COLOR AllocNamedColor ALLOC-COLOR AllocColorCells ALLOC-COLOR-CELLS AllocColorPlanes ALLOC-COLOR-PLANES AllowEvents ALLOW-EVENTS GetAtomName ATOM-NAME Bell BELL ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB ChangeKeyboardControl CHANGE-KEYBOARD-CONTROL SetKeyboardMapping CHANGE-KEYBOARD-MAPPING ChangePointerControl CHANGE-POINTER-CONTROL ChangeProperty CHANGE-PROPERTY QueryFont CHAR-ASCENT QueryFont CHAR-ATTRIBUTES QueryFont CHAR-DESCENT QueryFont CHAR-LEFT-BEARING QueryFont CHAR-RIGHT-BEARING QueryFont CHAR-WIDTH CirculateWindow CIRCULATE-WINDOW-DOWN CirculateWindow CIRCULATE-WINDOW-UP ClearToBackground CLEAR-AREA CloseFont CLOSE-FONT ConvertSelection CONVERT-SELECTION CopyArea COPY-AREA CopyColormapAndFree COPY-COLORMAP-AND-FREE CopyGC COPY-GCONTEXT CopyGC COPY-GCONTEXT-COMPONENTS CopyPlane COPY-PLANE CreateColormap CREATE-COLORMAP CreateCursor CREATE-CURSOR CreateGC CREATE-GCONTEXT CreateGlyphCursor CREATE-GLYPH-CURSOR CreatePixmap CREATE-PIXMAP CreateWindow CREATE-WINDOW DeleteProperty DELETE-PROPERTY DestroySubwindows DESTROY-SUBWINDOWS DestroyWindow DESTROY-WINDOW PolyArc DRAW-ARC PolyArc DRAW-ARCS PolyText16 DRAW-GLYPH PolyText16 DRAW-GLYPHS PolyText8 DRAW-GLYPHS ImageText16 DRAW-IMAGE-GLYPH ImageText16 DRAW-IMAGE-GLYPHS ImageText8 DRAW-IMAGE-GLYPHS PolyLine DRAW-LINE PolyLine DRAW-LINES PolyPoint DRAW-POINT PolyPoint DRAW-POINTS PolyFillRectangle DRAW-RECTANGLE PolyRectangle DRAW-RECTANGLE PolyFillRectangle DRAW-RECTANGLES PolyRectangle DRAW-RECTANGLES PolySegment DRAW-SEGMENTS GetGeometry DRAWABLE-BORDER-WIDTH GetGeometry DRAWABLE-DEPTH GetGeometry DRAWABLE-HEIGHT GetGeometry DRAWABLE-ROOT GetGeometry DRAWABLE-WIDTH GetGeometry DRAWABLE-X GetGeometry DRAWABLE-Y FillPoly FILL-POLYGON InternAtom FIND-ATOM QueryFont FONT-ALL-CHARS-EXIST-P QueryFont FONT-ASCENT QueryFont FONT-DEFAULT-CHAR QueryFont FONT-DESCENT QueryFont FONT-DIRECTION QueryFont FONT-MAX-BYTE1 QueryFont FONT-MAX-BYTE2 QueryFont FONT-MAX-CHAR QueryFont FONT-MIN-BYTE1 QueryFont FONT-MIN-BYTE2 QueryFont FONT-MIN-CHAR QueryFont FONT-NAME QueryFont FONT-NAME GetFontPath FONT-PATH QueryFont FONT-PROPERTIES QueryFont FONT-PROPERTY ChangeGC FORCE-GCONTEXT-CHANGES SetClipRectangles FORCE-GCONTEXT-CHANGES SetDashes FORCE-GCONTEXT-CHANGES FreeColormap FREE-COLORMAP FreeColors FREE-COLORS FreeCursor FREE-CURSOR FreeGC FREE-GCONTEXT FreePixmap FREE-PIXMAP GetProperty GET-PROPERTY GetImage GET-RAW-IMAGE QueryPointer GLOBAL-POINTER-POSITION GrabButton GRAB-BUTTON GrabKey GRAB-KEY GrabKeyboard GRAB-KEYBOARD GrabPointer GRAB-POINTER GrabServer GRAB-SERVER GrabServer WITH-SERVER-GRABBED GetInputFocus INPUT-FOCUS InstallColormap INSTALL-COLORMAP ListInstalledColormaps INSTALLED-COLORMAPS InternAtom INTERN-ATOM GetKeyboardControl KEYBOARD-CONTROL GetKeyboardMapping KEYBOARD-MAPPING KillClient KILL-CLIENT KillClient KILL-TEMPORARY-CLIENTS ListExtensions LIST-EXTENSIONS ListFonts LIST-FONT-NAMES ListFontsWithInfo LIST-FONTS ListProperties LIST-PROPERTIES LookupColor LOOKUP-COLOR MapSubwindows MAP-SUBWINDOWS MapWindow MAP-WINDOW QueryFont MAX-CHAR-ASCENT QueryFont MAX-CHAR-ATTRIBUTES QueryFont MAX-CHAR-DESCENT QueryFont MAX-CHAR-LEFT-BEARING QueryFont MAX-CHAR-RIGHT-BEARING QueryFont MAX-CHAR-WIDTH QueryFont MIN-CHAR-ASCENT QueryFont MIN-CHAR-ATTRIBUTES QueryFont MIN-CHAR-DESCENT QueryFont MIN-CHAR-LEFT-BEARING QueryFont MIN-CHAR-RIGHT-BEARING QueryFont MIN-CHAR-WIDTH GetModifierMapping MODIFIER-MAPPING GetMotionEvents MOTION-EVENTS NoOperation NO-OPERATION OpenFont OPEN-FONT GetPointerControl POINTER-CONTROL GetPointerMapping POINTER-MAPPING QueryPointer POINTER-POSITION PutImage PUT-RAW-IMAGE QueryBestSize QUERY-BEST-CURSOR QueryBestSize QUERY-BEST-STIPPLE QueryBestSize QUERY-BEST-TILE QueryColors QUERY-COLORS QueryExtension QUERY-EXTENSION QueryKeymap QUERY-KEYMAP QueryPointer QUERY-POINTER QueryTree QUERY-TREE RecolorCursor RECOLOR-CURSOR ChangeHosts REMOVE-ACCESS-HOST ChangeSaveSet REMOVE-FROM-SAVE-SET ReparentWindow REPARENT-WINDOW ForceScreenSaver RESET-SCREEN-SAVER RotateProperties ROTATE-PROPERTIES GetScreenSaver SCREEN-SAVER GetSelectionOwner SELECTION-OWNER SendEvent SEND-EVENT ChangeAccessControl SET-ACCESS-CONTROL ChangeCloseDownMode SET-CLOSE-DOWN-MODE SetInputFocus SET-INPUT-FOCUS SetModifierMapping SET-MODIFIER-MAPPING SetPointerMapping SET-POINTER-MAPPING SetScreenSaver SET-SCREEN-SAVER SetSelectionOwner SET-SELECTION-OWNER StoreColors STORE-COLOR StoreColors STORE-COLORS StoreNamedColor STORE-COLOR StoreNamedColor STORE-COLORS QueryTextExtents TEXT-EXTENTS QueryTextExtents TEXT-WIDTH TranslateCoords TRANSLATE-COORDINATES UngrabButton UNGRAB-BUTTON UngrabKey UNGRAB-KEY UngrabKeyboard UNGRAB-KEYBOARD UngrabPointer UNGRAB-POINTER UngrabServer UNGRAB-SERVER UngrabServer WITH-SERVER-GRABBED UninstallColormap UNINSTALL-COLORMAP UnmapSubwindows UNMAP-SUBWINDOWS UnmapWindow UNMAP-WINDOW WarpPointer WARP-POINTER WarpPointer WARP-POINTER-IF-INSIDE WarpPointer WARP-POINTER-RELATIVE WarpPointer WARP-POINTER-RELATIVE-IF-INSIDE GetWindowAttributes WINDOW-ALL-EVENT-MASKS GetWindowAttributes WINDOW-BACKING-PIXEL GetWindowAttributes WINDOW-BACKING-PLANES GetWindowAttributes WINDOW-BACKING-STORE GetWindowAttributes WINDOW-BIT-GRAVITY GetWindowAttributes WINDOW-CLASS GetWindowAttributes WINDOW-COLORMAP GetWindowAttributes WINDOW-COLORMAP-INSTALLED-P GetWindowAttributes WINDOW-DO-NOT-PROPAGATE-MASK GetWindowAttributes WINDOW-EVENT-MASK GetWindowAttributes WINDOW-GRAVITY GetWindowAttributes WINDOW-MAP-STATE GetWindowAttributes WINDOW-OVERRIDE-REDIRECT GetWindowAttributes WINDOW-SAVE-UNDER GetWindowAttributes WINDOW-VISUAL-INFO ConfigureWindow (SETF (DRAWABLE-BORDER-WIDTH DRAWABLE) INTEGER) ConfigureWindow (SETF (DRAWABLE-DEPTH DRAWABLE) INTEGER) ConfigureWindow (SETF (DRAWABLE-HEIGHT DRAWABLE) INTEGER) ConfigureWindow (SETF (DRAWABLE-WIDTH DRAWABLE) INTEGER) ConfigureWindow (SETF (DRAWABLE-X DRAWABLE) INTEGER) ConfigureWindow (SETF (DRAWABLE-Y DRAWABLE) INTEGER) SetFontPath (SETF (FONT-PATH FONT) PATHS) ChangeGC (SETF (GCONTEXT-ARC-MODE GC) (MEMBER CHORD PIE-SLICE)) ChangeGC (SETF (GCONTEXT-BACKGROUND GC) CARD32) ChangeGC (SETF (GCONTEXT-CAP-STYLE GC) KEYWORD) SetClipRectangles (SETF (GCONTEXT-CLIP-MASK GC &OPTIONAL ORDERING) (OR (MEMBER NONE) PIXMAP RECT-SEQ)) SetClipRectangles (SETF (GCONTEXT-CLIP-ORDERING GC) KEYWORD) SetClipRectangles (SETF (GCONTEXT-CLIP-X GC) INT16) SetClipRectangles (SETF (GCONTEXT-CLIP-Y GC) INT16) SetDashes (SETF (GCONTEXT-DASH-OFFSET GC) CARD16) SetDashes (SETF (GCONTEXT-DASHES GC) (OR CARD8 SEQUENCE)) ChangeGC (SETF (GCONTEXT-EXPOSURES GC) (MEMBER ON OFF)) ChangeGC (SETF (GCONTEXT-FILL-RULE GC) KEYWORD) ChangeGC (SETF (GCONTEXT-FILL-STYLE GC) KEYWORD) ChangeGC (SETF (GCONTEXT-FONT GC &OPTIONAL METRICS-P) FONT) ChangeGC (SETF (GCONTEXT-FOREGROUND GC) CARD32) ChangeGC (SETF (GCONTEXT-FUNCTION GC) BOOLE-CONSTANT) ChangeGC (SETF (GCONTEXT-JOIN-STYLE GC) KEYWORD) ChangeGC (SETF (GCONTEXT-LINE-STYLE GC) KEYWORD) ChangeGC (SETF (GCONTEXT-LINE-WIDTH GC) CARD16) ChangeGC (SETF (GCONTEXT-PLANE-MASK GC) CARD32) ChangeGC (SETF (GCONTEXT-STIPPLE GC) PIXMAP) ChangeGC (SETF (GCONTEXT-SUBWINDOW-MODE GC) KEYWORD) ChangeGC (SETF (GCONTEXT-TILE GC) PIXMAP) ChangeGC (SETF (GCONTEXT-TS-X GC) INT16) ChangeGC (SETF (GCONTEXT-TS-Y GC) INT16) ChangeWindowAttributes (SETF (WINDOW-BACKGROUND WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-BACKING-PIXEL WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-BACKING-PLANES WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-BACKING-STORE WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-BIT-GRAVITY WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-BORDER WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-COLORMAP WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-CURSOR WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-DO-NOT-PROPAGATE-MASK WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-EVENT-MASK WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-GRAVITY WINDOW) VALUE) ChangeWindowAttributes (SETF (WINDOW-OVERRIDE-REDIRECT WINDOW) VALUE) ConfigureWindow (SETF (WINDOW-PRIORITY WINDOW &OPTIONAL SIBLING) INTEGER) ChangeWindowAttributes (SETF (WINDOW-SAVE-UNDER WINDOW) VALUE) ;; Here's a list of the CLX functions that don't directly correspond to ;; X Window System requests. The've been categorized by function: ;Display Management CLOSE-DISPLAY CLOSE-DOWN-MODE DISPLAY-AFTER-FUNCTION ;; SETF'able DISPLAY-FINISH-OUTPUT DISPLAY-FORCE-OUTPUT DISPLAY-INVOKE-AFTER-FUNCTION OPEN-DISPLAY WITH-DISPLAY WITH-EVENT-QUEUE ;Extensions DECLARE-EVENT DECODE-CORE-ERROR DEFAULT-ERROR-HANDLER DEFINE-CONDITION DEFINE-ERROR DEFINE-EXTENSION DEFINE-GCONTEXT-ACCESSOR EXTENSION-OPCODE ;Events EVENT-CASE EVENT-LISTEN MAPPING-NOTIFY PROCESS-EVENT EVENT-HANDLER MAKE-EVENT-HANDLERS QUEUE-EVENT ;Image COPY-IMAGE CREATE-IMAGE GET-IMAGE IMAGE-BLUE-MASK IMAGE-DEPTH IMAGE-GREEN-MASK IMAGE-HEIGHT IMAGE-NAME IMAGE-PIXMAP IMAGE-PLIST IMAGE-RED-MASK IMAGE-WIDTH IMAGE-X-HOT IMAGE-Y-HOT PUT-IMAGE READ-BITMAP-FILE WRITE-BITMAP-FILE ;Keysyms CHARACTER->KEYSYMS CHARACTER-IN-MAP-P DEFAULT-KEYSYM-INDEX DEFAULT-KEYSYM-TRANSLATE DEFINE-KEYSYM DEFINE-KEYSYM-SET KEYCODE->CHARACTER KEYCODE->KEYSYM KEYSYM KEYSYM->CHARACTER KEYSYM-IN-MAP-P KEYSYM-SET UNDEFINE-KEYSYM ;Properties CUT-BUFFER GET-STANDARD-COLORMAP GET-WM-CLASS ICON-SIZES MAKE-WM-HINTS MAKE-WM-SIZE-HINTS ROTATE-CUT-BUFFERS SET-STANDARD-COLORMAP SET-WM-CLASS TRANSIENT-FOR WM-CLIENT-MACHINE WM-COMMAND WM-HINTS WM-HINTS-FLAGS WM-HINTS-ICON-MASK WM-HINTS-ICON-PIXMAP WM-HINTS-ICON-WINDOW WM-HINTS-ICON-X WM-HINTS-ICON-Y WM-HINTS-INITIAL-STATE WM-HINTS-INPUT WM-HINTS-P WM-HINTS-WINDOW-GROUP WM-ICON-NAME WM-NAME WM-NORMAL-HINTS WM-SIZE-HINTS-HEIGHT WM-SIZE-HINTS-HEIGHT-INC WM-SIZE-HINTS-MAX-ASPECT WM-SIZE-HINTS-MAX-HEIGHT WM-SIZE-HINTS-MAX-WIDTH WM-SIZE-HINTS-MIN-ASPECT WM-SIZE-HINTS-MIN-HEIGHT WM-SIZE-HINTS-MIN-WIDTH WM-SIZE-HINTS-P WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P WM-SIZE-HINTS-WIDTH WM-SIZE-HINTS-WIDTH-INC WM-SIZE-HINTS-X WM-SIZE-HINTS-Y WM-ZOOM-HINTS ;Misc. MAKE-COLOR MAKE-EVENT-KEYS MAKE-EVENT-MASK MAKE-RESOURCE-DATABASE MAKE-STATE-KEYS MAKE-STATE-MASK DISCARD-FONT-INFO TRANSLATE-DEFAULT ;Structures BITMAP-FORMAT-LSB-FIRST-P BITMAP-FORMAT-P BITMAP-FORMAT-PAD BITMAP-FORMAT-UNIT BITMAP-IMAGE COLOR-BLUE COLOR-GREEN COLOR-P COLOR-RED COLOR-RGB COLORMAP-DISPLAY COLORMAP-EQUAL COLORMAP-ID COLORMAP-P COLORMAP-VISUAL-INFO CURSOR-DISPLAY CURSOR-EQUAL CURSOR-ID CURSOR-P DRAWABLE-DISPLAY DRAWABLE-EQUAL DRAWABLE-ID DRAWABLE-P FONT-DISPLAY FONT-EQUAL FONT-ID FONT-MAX-BOUNDS FONT-MIN-BOUNDS FONT-P FONT-PLIST GCONTEXT-DISPLAY GCONTEXT-EQUAL GCONTEXT-ID GCONTEXT-P GCONTEXT-PLIST DISPLAY-AUTHORIZATION-DATA DISPLAY-AUTHORIZATION-NAME DISPLAY-BITMAP-FORMAT DISPLAY-BYTE-ORDER DISPLAY-DEFAULT-SCREEN DISPLAY-DISPLAY DISPLAY-ERROR-HANDLER DISPLAY-IMAGE-LSB-FIRST-P DISPLAY-KEYCODE-RANGE DISPLAY-MAX-KEYCODE DISPLAY-MAX-REQUEST-LENGTH DISPLAY-MIN-KEYCODE DISPLAY-MOTION-BUFFER-SIZE DISPLAY-NSCREENS DISPLAY-P DISPLAY-PIXMAP-FORMATS DISPLAY-PLIST DISPLAY-PROTOCOL-MAJOR-VERSION DISPLAY-PROTOCOL-MINOR-VERSION DISPLAY-PROTOCOL-VERSION DISPLAY-RELEASE-NUMBER DISPLAY-RESOURCE-ID-BASE DISPLAY-RESOURCE-ID-MASK DISPLAY-ROOTS DISPLAY-SQUISH DISPLAY-VENDOR DISPLAY-VENDOR-NAME DISPLAY-VERSION-NUMBER DISPLAY-XDEFAULTS DISPLAY-XID PIXMAP-DISPLAY PIXMAP-EQUAL PIXMAP-FORMAT-BITS-PER-PIXEL PIXMAP-FORMAT-DEPTH PIXMAP-FORMAT-P PIXMAP-FORMAT-SCANLINE-PAD PIXMAP-ID PIXMAP-P PIXMAP-PLIST SCREEN-BACKING-STORES SCREEN-BLACK-PIXEL SCREEN-DEFAULT-COLORMAP SCREEN-DEPTHS SCREEN-EVENT-MASK-AT-OPEN SCREEN-HEIGHT SCREEN-HEIGHT-IN-MILLIMETERS SCREEN-MAX-INSTALLED-MAPS SCREEN-MIN-INSTALLED-MAPS SCREEN-P SCREEN-PLIST SCREEN-ROOT SCREEN-ROOT-DEPTH SCREEN-ROOT-VISUAL-INFO SCREEN-SAVE-UNDERS-P SCREEN-WHITE-PIXEL SCREEN-WIDTH SCREEN-WIDTH-IN-MILLIMETERS VISUAL-INFO VISUAL-INFO-BITS-PER-RGB VISUAL-INFO-BLUE-MASK VISUAL-INFO-CLASS VISUAL-INFO-COLORMAP-ENTRIES VISUAL-INFO-GREEN-MASK VISUAL-INFO-ID VISUAL-INFO-P VISUAL-INFO-PLIST VISUAL-INFO-RED-MASK WINDOW-DISPLAY WINDOW-EQUAL WINDOW-ID WINDOW-P WINDOW-PLIST cmucl-21a/src/clx/dpms.lisp000066400000000000000000000136651260377556400160050ustar00rootroot00000000000000 ;;;; Original Author: Matthew Kennedy ;;;; ;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11 ;;;; server implementation. DPMS.txt contains the following copyright: ;;;; ;;;; Copyright (C) Digital Equipment Corporation, 1996 ;;;; ;;;; Permission to use, copy, modify, distribute, and sell this documentation ;;;; for any purpose is hereby granted without fee, provided that the above ;;;; copyright notice and this permission notice appear in all copies. Digital ;;;; Equipment Corporation makes no representations about the suitability for ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. #+cmu (ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (defpackage :dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" "DISPLAY" "WITH-BUFFER-REQUEST-AND-REPLY" "WITH-BUFFER-REQUEST" "EXTENSION-OPCODE" "CARD8-GET" "CARD16-GET" "BOOLEAN-GET" "CARD8" "CARD16" "DATA") (:export "DPMS-GET-VERSION" "DPMS-CAPABLE" "DPMS-GET-TIMEOUTS" "DPMS-SET-TIMEOUTS" "DPMS-ENABLE" "DPMS-DISABLE" "DPMS-FORCE-LEVEL" "DPMS-INFO")) (in-package :dpms) (define-extension "DPMS") (defmacro dpms-opcode (display) `(extension-opcode ,display "DPMS")) (defconstant +get-version+ 0) (defconstant +capable+ 1) (defconstant +get-timeouts+ 2) (defconstant +set-timeouts+ 3) (defconstant +enable+ 4) (defconstant +disable+ 5) (defconstant +force-level+ 6) (defconstant +info+ 7) (defun dpms-get-version (display &optional (major-version 1) (minor-version 1)) "Return two values: the major and minor version of the DPMS implementation the server supports. If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what version of the protocol the client wants the server to implement." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-version+) (card16 major-version) (card16 minor-version)) (values (card16-get 8) (card16-get 10)))) (defun dpms-capable (display) "True if the currently running server's devices are capable of DPMS operations. The truth value of this request is implementation defined, but is generally based on the capabilities of the graphic card and monitor combination. Also, the return value in the case of heterogeneous multi-head servers is implementation defined." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +capable+)) (boolean-get 8))) (defun dpms-get-timeouts (display) "Return three values: the current values of the DPMS timeout values. The timeout values are (in order returned): standby, suspend and off. All values are in units of seconds. A value of zero for any timeout value indicates that the mode is disabled." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +get-timeouts+)) (values (card16-get 8) (card16-get 10) (card16-get 12)))) (defun dpms-set-timeouts (display standby suspend off) "Set the values of the DPMS timeouts. All values are in units of seconds. A value of zero for any timeout value disables that mode." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +set-timeouts+) (card16 standby) (card16 suspend) (card16 off) (card16 0)) ;unused (values)) (defun dpms-enable (display) "Enable the DPMS characteristics of the server using the server's currently stored timeouts. If DPMS is already enabled, no change is affected." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +enable+)) (values)) (defun dpms-disable (display) "Disable the DPMS characteristics of the server. It does not affect the core or extension screen savers. If DPMS is already disabled, no change is effected. This request is provided so that DPMS may be disabled without damaging the server's stored timeout values." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) ((data +disable+))) (values)) (defun dpms-force-level (display power-level) "Forces a specific DPMS level on the server. Valid keyword values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND and DPMS-MODE-OFF." (declare (type display display)) (with-buffer-request (display (dpms-opcode display)) (data +force-level+) (card16 (ecase power-level (:dpms-mode-on 0) (:dpms-mode-standby 1) (:dpms-mode-suspend 2) (:dpms-mode-off 3))) (card16 0)) ;unused (values)) (defun dpms-info (display) "Returns two valus: the DPMS power-level and state value for the display. State is one of the keywords DPMS-ENABLED or DPMS-DISABLED. If state is DPMS-ENABLED, then power level is returned as one of the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is undefined and returned as NIL." (declare (type display display)) (with-buffer-request-and-reply (display (dpms-opcode display) nil) ((data +info+)) (let ((state (if (boolean-get 10) :dpms-enabled :dpms-disabled))) (values (unless (eq state :dpms-disabled) (ecase (card16-get 8) (0 :dpms-mode-on) (1 :dpms-mode-standby) (2 :dpms-mode-suspend) (3 :dpms-mode-off))) state)))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cmucl-21a/src/clx/exclMakefile000066400000000000000000000122371260377556400164570ustar00rootroot00000000000000# # Makefile for CLX # (X11 R4.4 release, Franz Allegro Common Lisp version) # # $Id: exclMakefile,v 1.5 2009/06/17 18:22:46 rtoy Rel $ # # ************************************************************************* # * Change the next line to point to where you have Common Lisp installed * # * (make sure the Lisp doesn't already have CLX loaded in) * # ************************************************************************* CL = /usr/local/bin/cl RM = /bin/rm SHELL = /bin/sh ECHO = /bin/echo TAGS = /usr/local/lib/emacs/etc/etags # Name of dumped lisp CLX = CLX CLOPTS = -qq # Use this one for Suns CFLAGS = -O -DUNIXCONN # Use this one for Silicon Graphics & Mips Inc MIPS based machines # CFLAGS = -O -G 0 -I/usr/include/bsd # Use this one for DEC MIPS based machines # CFLAGS = -O -G 0 -DUNIXCONN # Use this one for HP machines # CFLAGS = -O -DSYSV -DUNIXCONN # Lisp optimization for compiling SPEED = 3 SAFETY = 0 C_SRC = excldep.c socket.c C_OBJS = excldep.o socket.o L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ manager.fasl image.fasl resource.fasl L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ dependent.fasl buffer.fasl display.fasl gcontext.fasl \ requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ resource.fasl L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ display.cl gcontext.cl requests.cl input.cl fonts.cl \ graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ manager.cl image.cl resource.cl # default and aliases all: no-clos # all: partial-clos compile-CLX-for-CLUE: compile-partial-clos-CLX clue: partial-clos # # Three build rules are provided: no-clos, partial-clos, and full-clos. # The first is no-clos, which results in a CLX whose datastructures are # all defstructs. partial-clos results in xlib:window, xlib:pixmap, and # xlib:drawable being CLOS instances, all others defstructs. full-clos # makes all CLX complex datatypes into CLOS instances. # # (note that the :clos feature implies native CLOS *not* PCL). # no-clos: $(C_OBJS) compile-no-clos-CLX cat # # This rule is used to compile CLX to be used with XCW version 2, or CLUE. # partial-clos: $(C_OBJS) compile-partial-clos-CLX cat full-clos: $(C_OBJS) compile-full-clos-CLX cat c: $(C_OBJS) compile-no-clos-CLX: $(C_OBJS) $(ECHO) " \ (set-case-mode :case-sensitive-lower) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ #+allegro (compile-system :clx) \ #-allegro (compile-clx) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch compile-partial-clos-CLX: $(C_OBJS) $(ECHO) " \ #+clos (set-case-mode :case-sensitive-lower) \ #-clos (setq excl::*print-nickname* t) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (unless (or (find-package 'clos) (find-package 'pcl)) \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (require :pcl) \ (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ #+allegro (compile-system :clx) \ #-allegro (compile-clx \"\" \"\" :for-clue t) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch compile-full-clos-CLX: $(C_OBJS) $(ECHO) " \ #+clos (set-case-mode :case-sensitive-lower) \ #-clos (setq excl::*print-nickname* t) \ (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ (unless (or (find-package 'clos) (find-package 'pcl)) \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (require :pcl) \ (provide :pcl) \ (gc) (gc) \ (setf (sys:gsgc-parameter :generation-spread) spread))) \ #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ (load \"defsystem\") \ (load \"package\") \ (setq xlib::*def-clx-class-use-defclass* t) \ #+allegro (compile-system :clx) \ #-allegro (compile-clx \"\" \"\" :for-clue t) \ #+allegro (compile-system :clx-debug)" \ | $(CL) $(CLOPTS) -batch cat: -cat $(L_NOMACROS_OBJS) > CLX.fasl load-CLX: $(ECHO) " \ (let ((spread (sys:gsgc-parameter :generation-spread))) \ (setf (sys:gsgc-parameter :generation-spread) 1) \ (load \"defsystem\") \ #+allegro (load-system :clx) \ #-allegro (load-clx) \ (gc :tenure) \ (setf (sys:gsgc-parameter :generation-spread) spread)) \ (gc t)" \ '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ "(exit)" | $(CL) $(CLOPTS) clean: $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out install: mv CLX.fasl $(DEST)/clx.fasl mv *.o $(DEST) tags: $(TAGS) $(L_SRC) $(C_SRC) cmucl-21a/src/clx/exclREADME000066400000000000000000000041651260377556400157000ustar00rootroot00000000000000$Id: exclREADME,v 1.5 2009/06/17 18:22:46 rtoy Rel $ This file contains instructions on how to make CLX work with Franz Common Lisp. CLX should work on any machine that supports Allegro Common Lisp version 3.0.1 or greater. It also works under ExCL version 2.0.10. However it has been tested extensively with only Allegro CL versions 3.0, 3.1, and 4.0. There are three steps to compile and install CLX. The first is simply moving files around. In this directory, execute (assuming you using csh): % foreach i (*.l */*.l) ? mv $i $i:r.cl ? end % mv exclMakefile Makefile The second is compiling the source files into fasl files. The fasl files will be combined into one big fasl file, CLX.fasl. This file is then installed in your Common Lisp library directory in the next step. You may need to edit the Makefile to select the proper CFLAGS for your machine -- look in Makefile for examples. Then just: % make Now you must move the CLX.fasl file into the standard CL library. This is normally "/usr/local/lib/cl/code", but you can find out for sure by typing: (directory-namestring excl::*library-code-pathname*) to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" substitute what it prints in the below instructions. % mv CLX.fasl /usr/local/lib/cl/code/clx.fasl % mv *.o /usr/local/lib/cl/code Now you can just start up Lisp and type: (load "clx") to load in CLX. You may want to dump a lisp at this point since CLX is a large package and can take some time to load into Lisp. You probably also want to set the :generation-spread to 1 while loading CLX. Please see your Allegro CL User Guide for more information on :generation-spread. Sophisticated users may wish to peruse the Makefile and defsystem.cl and note how things are set up. For example we hardwire the compiler interrupt check switch on, so that CL can still be interrupted while it is reading from the X11 socket. Please see chapter 7 of the CL User's guide for more information on compiler switches and their effects. Please report Franz specific CLX bugs to: ucbvax!franz!bugs or bugs@Franz.COM cmucl-21a/src/clx/exclcmac.lisp000066400000000000000000000165611260377556400166170ustar00rootroot00000000000000;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; CLX -- exclcmac.cl ;;; This file provides for inline expansion of some functions. ;;; ;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) ;; ;; Type predicates ;; (excl:defcmacro card8p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) (excl:defcmacro card16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) (excl:defcmacro int8p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) (excl:defcmacro int16p (x) (let ((xx (gensym))) `(let ((,xx ,x)) (declare (optimize (speed 3) (safety 0)) (fixnum ,xx)) (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) ;; Card29p, card32p, int32p are too large to expand inline ;; ;; Type transformers ;; (excl:defcmacro card8->int8 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card8 ,xx)) (the int8 (if (logbitp 7 ,xx) (the int8 (- ,xx #x100)) ,xx))))) (excl:defcmacro int8->card8 (x) `(locally ,(declare-bufmac) (the card8 (ldb (byte 8 0) (the int8 ,x))))) (excl:defcmacro card16->int16 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card16 ,xx)) (the int16 (if (logbitp 15 ,xx) (the int16 (- ,xx #x10000)) ,xx))))) (excl:defcmacro int16->card16 (x) `(locally ,(declare-bufmac) (the card16 (ldb (byte 16 0) (the int16 ,x))))) (excl:defcmacro card32->int32 (x) (let ((xx (gensym))) `(let ((,xx ,x)) ,(declare-bufmac) (declare (type card32 ,xx)) (the int32 (if (logbitp 31 ,xx) (the int32 (- ,xx #x100000000)) ,xx))))) (excl:defcmacro int32->card32 (x) `(locally ,(declare-bufmac) (the card32 (ldb (byte 32 0) (the int32 ,x))))) (excl:defcmacro char->card8 (char) `(locally ,(declare-bufmac) (the card8 (char-code (the string-char ,char))))) (excl:defcmacro card8->char (card8) `(locally ,(declare-bufmac) (the string-char (code-char (the card8 ,card8))))) ;; ;; Array accessors and setters ;; (excl:defcmacro aref-card8 (a i) `(locally ,(declare-bufmac) (the card8 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-byte)))) (excl:defcmacro aset-card8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-byte) (the card8 ,v)))) (excl:defcmacro aref-int8 (a i) `(locally ,(declare-bufmac) (the int8 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-byte)))) (excl:defcmacro aset-int8 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-byte) (the int8 ,v)))) (excl:defcmacro aref-card16 (a i) `(locally ,(declare-bufmac) (the card16 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-word)))) (excl:defcmacro aset-card16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-word) (the card16 ,v)))) (excl:defcmacro aref-int16 (a i) `(locally ,(declare-bufmac) (the int16 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-word)))) (excl:defcmacro aset-int16 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-word) (the int16 ,v)))) (excl:defcmacro aref-card32 (a i) `(locally ,(declare-bufmac) (the card32 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long)))) (excl:defcmacro aset-card32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long) (the card32 ,v)))) (excl:defcmacro aref-int32 (a i) `(locally ,(declare-bufmac) (the int32 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-long)))) (excl:defcmacro aset-int32 (v a i) `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :signed-long) (the int32 ,v)))) (excl:defcmacro aref-card29 (a i) ;; Don't need to mask bits here since X protocol guarantees top bits zero `(locally ,(declare-bufmac) (the card29 (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long)))) (excl:defcmacro aset-card29 (v a i) ;; I also assume here Lisp is passing a number that fits in 29 bits. `(locally ,(declare-bufmac) (setf (sys:memref (the buffer-bytes ,a) #.(comp::mdparam 'comp::md-svector-data0-adj) (the array-index ,i) :unsigned-long) (the card29 ,v)))) ;; ;; Font accessors ;; (excl:defcmacro font-id (font) ;; Get font-id, opening font if needed (let ((f (gensym))) `(let ((,f ,font)) (or (font-id-internal ,f) (open-font-internal ,f))))) (excl:defcmacro font-font-info (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-font-info-internal ,f) (query-font ,f))))) (excl:defcmacro font-char-infos (font) (let ((f (gensym))) `(let ((,f ,font)) (or (font-char-infos-internal ,f) (progn (query-font ,f) (font-char-infos-internal ,f)))))) ;; ;; Miscellaneous ;; (excl:defcmacro current-process () `(the (or mp::process null) (and mp::*scheduler-stack-group* mp::*current-process*))) (excl:defcmacro process-wakeup (process) (let ((proc (gensym))) `(let ((.pw-curproc. mp::*current-process*) (,proc ,process)) (when (and .pw-curproc. ,proc) (if (> (mp::process-priority ,proc) (mp::process-priority .pw-curproc.)) (mp::process-allow-schedule ,proc)))))) (excl:defcmacro buffer-new-request-number (buffer) (let ((buf (gensym))) `(let ((,buf ,buffer)) (declare (type buffer ,buf)) (setf (buffer-request-number ,buf) (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) cmucl-21a/src/clx/excldefsys.lisp000066400000000000000000000135621260377556400172070ustar00rootroot00000000000000;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without express or ;;; implied warranty. ;;; #+cmu (ext:file-comment "$Id") (in-package :xlib :use '(:foreign-functions :lisp :excl)) #+allegro (require :defsystem "defsys") (eval-when (load) (require :clxexcldep "excldep")) ;; ;; The following is a suggestion. If you comment out this form be ;; prepared for possible deadlock, since no interrupts will be recognized ;; while reading from the X socket if the scheduler is not running. ;; (setq compiler::generate-interrupt-checks-switch (compile nil '(lambda (safety size speed) (declare (ignore size)) (or (< speed 3) (> safety 0))))) #+allegro (excl:defsystem :clx () |depdefs| (|clx| :load-before-compile (|depdefs|) :recompile-on (|depdefs|)) (|dependent| :load-before-compile (|depdefs| |clx|) :recompile-on (|clx|)) (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|) :recompile-on (|dependent|)) (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|) :recompile-on (|exclcmac|)) (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros|) :recompile-on (|macros|)) (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac|) :recompile-on (|bufmac|)) (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer|) :recompile-on (|buffer|)) (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |input|) :recompile-on (|display|)) (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |fonts|) :recompile-on (|fonts|)) (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |gcontext| |fonts|) :recompile-on (|gcontext| |fonts|) :load-after (|translate|)) ;; The above line gets around a compiler macro expansion bug. (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |text|) :recompile-on (|display|)) (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| |translate|) :recompile-on (|translate|)) (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display| ) :recompile-on (|display|)) ;; Don't know if l-b-c list is correct. XX (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros| |bufmac| |buffer| |display|) :recompile-on (|display|)) ) #+allegro (excl:defsystem :clx-debug (:default-pathname "debug/" :needed-systems (:clx) :load-before-compile (:clx)) |describe| |keytrans| |trace| |util|) (defun compile-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (compile-file "depdefs") (load "depdefs") (compile-file "clx") (load "clx") (compile-file "dependent") (load "dependent") (compile-file "macros") (load "macros") (compile-file "bufmac") (load "bufmac") (compile-file "buffer") (load "buffer") (compile-file "display") (load "display") (compile-file "gcontext") (load "gcontext") (compile-file "input") (load "input") (compile-file "requests") (load "requests") (compile-file "fonts") (load "fonts") (compile-file "graphics") (load "graphics") (compile-file "text") (load "text") (compile-file "attributes") (load "attributes") (load "translate") (compile-file "translate") ; work-around bug in 2.0 and 2.2 (load "translate") (compile-file "keysyms") (load "keysyms") (compile-file "manager") (load "manager") (compile-file "image") (load "image") (compile-file "resource") (load "resource") )) (defun load-clx (&optional pathname-defaults) (let ((*default-pathname-defaults* (or pathname-defaults *default-pathname-defaults*))) (declare (special *default-pathname-defaults*)) (load "depdefs") (load "clx") (load "dependent") (load "macros") (load "bufmac") (load "buffer") (load "display") (load "gcontext") (load "input") (load "requests") (load "fonts") (load "graphics") (load "text") (load "attributes") (load "translate") (load "keysyms") (load "manager") (load "image") (load "resource") )) cmucl-21a/src/clx/excldep.c000066400000000000000000000035661260377556400157400ustar00rootroot00000000000000/* * Allegro CL dependent C helper routines for CLX */ /* * $Id: excldep.c,v 1.4 2009/06/17 18:22:46 rtoy Rel $ */ /* * This code requires select and interval timers. * This means you probably need BSD, or a version * of Unix with select and interval timers added. */ #include #include #include #include #define ERROR -1 #define INTERRUPT -2 #define TIMEOUT 0 #define SUCCESS 1 #ifdef FD_SETSIZE #define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ #else #define NUMBER_OF_FDS 32 #endif /* Length of array needed to hold all file descriptor bits */ #define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) extern int errno; /* * This function waits for input to become available on 'fd'. If timeout is * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes * available before the timer expires, return SUCCESS. If the timer expires * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs * while waiting, return INTERRUPT. */ int fd_wait_for_input(fd, timeout) register int fd; register int timeout; { struct timeval timer; register int i; int checkfds[CHECKLEN]; if (fd < 0 || fd >= NUMBER_OF_FDS) { fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); fflush(stderr); } for (i = 0; i < CHECKLEN; i++) checkfds[i] = 0; checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); if (timeout) { timer.tv_sec = timeout; timer.tv_usec = 0; i = select(32, checkfds, (int *)0, (int *)0, &timer); } else i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); if (i < 0) /* error condition */ if (errno == EINTR) return (INTERRUPT); else return (ERROR); else if (i == 0) return (TIMEOUT); else return (SUCCESS); } cmucl-21a/src/clx/excldep.lisp000066400000000000000000000334541260377556400164640ustar00rootroot00000000000000;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- ;;; ;;; CLX -- excldep.cl ;;; ;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Franz Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: excldep.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (eval-when (compile load eval) (require :foreign) (require :process) ; Needed even if scheduler is not ; running. (Must be able to make ; a process-lock.) ) (eval-when (load) (provide :clx)) #-(or little-endian big-endian) (eval-when (eval compile load) (let ((x '#(1))) (if (not (eq 0 (sys::memref x #.(sys::mdparam 'comp::md-lvector-data0-norm) 0 :unsigned-byte))) (pushnew :little-endian *features*) (pushnew :big-endian *features*)))) (defmacro correct-case (string) ;; This macro converts the given string to the ;; current preferred case, or leaves it alone in a case-sensitive mode. (let ((str (gensym))) `(let ((,str ,string)) (case excl::*current-case-mode* (:case-insensitive-lower (string-downcase ,str)) (:case-insensitive-upper (string-upcase ,str)) ((:case-sensitive-lower :case-sensitive-upper) ,str))))) (defconstant type-pred-alist '(#-(version>= 4 1 devel 16) (card8 . card8p) #-(version>= 4 1 devel 16) (card16 . card16p) #-(version>= 4 1 devel 16) (card29 . card29p) #-(version>= 4 1 devel 16) (card32 . card32p) #-(version>= 4 1 devel 16) (int8 . int8p) #-(version>= 4 1 devel 16) (int16 . int16p) #-(version>= 4 1 devel 16) (int32 . int32p) #-(version>= 4 1 devel 16) (mask16 . card16p) #-(version>= 4 1 devel 16) (mask32 . card32p) #-(version>= 4 1 devel 16) (pixel . card32p) #-(version>= 4 1 devel 16) (resource-id . card29p) #-(version>= 4 1 devel 16) (keysym . card32p) (angle . anglep) (color . color-p) (bitmap-format . bitmap-format-p) (pixmap-format . pixmap-format-p) (display . display-p) (drawable . drawable-p) (window . window-p) (pixmap . pixmap-p) (visual-info . visual-info-p) (colormap . colormap-p) (cursor . cursor-p) (gcontext . gcontext-p) (screen . screen-p) (font . font-p) (image-x . image-x-p) (image-xy . image-xy-p) (image-z . image-z-p) (wm-hints . wm-hints-p) (wm-size-hints . wm-size-hints-p) )) ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old ;; sun4 compiler opencode the `and'. #-(version>= 4 1 devel 16) (defun card8p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) t nil)) #-(version>= 4 1 devel 16) (defun card16p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) t nil)) #-(version>= 4 1 devel 16) (defun card29p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) (>= (the bignum x) 0))) t nil)) #-(version>= 4 1 devel 16) (defun card32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) (>= (the bignum x) 0))) t nil)) #-(version>= 4 1 devel 16) (defun int8p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) t nil)) #-(version>= 4 1 devel 16) (defun int16p (x) (declare (optimize (speed 3) (safety 0)) (fixnum x)) (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) t nil)) #-(version>= 4 1 devel 16) (defun int32p (x) (declare (optimize (speed 3) (safety 0))) (if (or (excl:fixnump x) (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) (>= (the bignum x) #.(expt -2 31)))) t nil)) ;; This one can be handled better by knowing a little about what we're ;; testing for. Plus this version can handle (single-float pi), which ;; is otherwise larger than pi! (defun anglep (x) (declare (optimize (speed 3) (safety 0))) (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) (<= (the fixnum x) #.(truncate (* 2 pi)))) (and (excl::single-float-p x) (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) (and (excl::double-float-p x) (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) t nil)) (eval-when (load eval) #+(version>= 4 1 devel 16) (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) type-pred-alist) #-(version>= 4 1 devel 16) (nconc excl::type-pred-alist type-pred-alist)) ;; Return t if there is a character available for reading or on error, ;; otherwise return nil. #-(version>= 6 0) (progn #-(or (version>= 4 2) mswindows) (defun fd-char-avail-p (fd) (multiple-value-bind (available-p errcode) (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) (excl:if* errcode then t else available-p))) #+(and (version>= 4 2) (not mswindows)) (defun fd-char-avail-p (fd) (excl::filesys-character-available-p fd)) #+mswindows (defun fd-char-avail-p (socket-stream) (listen socket-stream)) ) #+(version>= 6 0) (defun fd-char-avail-p (socket-stream) (excl::read-no-hang-p socket-stream)) (defmacro with-interrupt-checking-on (&body body) `(locally (declare (optimize (safety 1))) ,@body)) ;; Read from the given fd into 'vector', which has element type card8. ;; Start storing at index 'start-index' and read exactly 'length' bytes. ;; Return t if an error or eof occurred, nil otherwise. (defun fd-read-bytes (fd vector start-index length) ;; Read from the given stream fd into 'vector', which has element type card8. ;; Start storing at index 'start-index' and read exactly 'length' bytes. ;; Return t if an error or eof occurred, nil otherwise. (declare (fixnum next-index start-index length)) (with-interrupt-checking-on (let ((end-index (+ start-index length))) (loop (let ((next-index (excl:read-vector vector fd :start start-index :end end-index))) (excl:if* (eq next-index start-index) then ; end of file before was all filled up (return t) elseif (eq next-index end-index) then ; we're all done (return nil) else (setq start-index next-index))))))) ;; special patch for CLX (various process fixes) ;; patch1000.2 (eval-when (compile load eval) (unless (find-package :patch) (make-package :patch :use '(:lisp :excl)))) (in-package :patch) (defvar *patches* nil) #+allegro (eval-when (compile eval load) (when (and (= excl::cl-major-version-number 3) (or (= excl::cl-minor-version-number 0) (and (= excl::cl-minor-version-number 1) excl::cl-generation-number (< excl::cl-generation-number 9)))) (push :clx-r4-process-patches *features*))) #+clx-r4-process-patches (push (cons 1000.2 "special patch for CLX (various process fixes)") *patches*) (in-package :mp) #+clx-r4-process-patches (export 'wait-for-input-available) #+clx-r4-process-patches (defun with-timeout-event (seconds fnc args) (unless *scheduler-stack-group* (start-scheduler)) ;[spr670] (let ((clock-event (make-clock-event))) (when (<= seconds 0) (setq seconds 0)) (multiple-value-bind (secs msecs) (truncate seconds) ;; secs is now a nonegative integer, and msecs is either fixnum zero ;; or else something interesting. (unless (eq 0 msecs) (setq msecs (truncate (* 1000.0 msecs)))) ;; Now msecs is also a nonnegative fixnum. (multiple-value-bind (now mnow) (excl::cl-internal-real-time) (incf secs now) (incf msecs mnow) (when (>= msecs 1000) (decf msecs 1000) (incf secs)) (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) (setf (clock-event-secs clock-event) secs (clock-event-msecs clock-event) msecs (clock-event-function clock-event) fnc (clock-event-args clock-event) args))) clock-event)) #+clx-r4-process-patches (defmacro with-timeout ((seconds &body timeout-body) &body body) `(let* ((clock-event (with-timeout-event ,seconds #'process-interrupt (cons *current-process* '(with-timeout-internal)))) (excl::*without-interrupts* t) ret) (unwind-protect ;; Warning: Branch tensioner better not reorder this code! (setq ret (catch 'with-timeout-internal (add-to-clock-queue clock-event) (let ((excl::*without-interrupts* nil)) (multiple-value-list (progn ,@body))))) (excl:if* (eq ret 'with-timeout-internal) then (let ((excl::*without-interrupts* nil)) (setq ret (multiple-value-list (progn ,@timeout-body)))) else (remove-from-clock-queue clock-event))) (values-list ret))) #+clx-r4-process-patches (defun process-lock (lock &optional (lock-value *current-process*) (whostate "Lock") timeout) (declare (optimize (speed 3))) (unless (process-lock-p lock) (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) (without-interrupts (excl:if* (null (process-lock-locker lock)) then (setf (process-lock-locker lock) lock-value) else (excl:if* timeout then (excl:if* (or (eq 0 timeout) ;for speed (zerop timeout)) then nil else (with-timeout (timeout) (process-lock-1 lock lock-value whostate))) else (process-lock-1 lock lock-value whostate))))) #+clx-r4-process-patches (defun process-lock-1 (lock lock-value whostate) (declare (type process-lock lock) (optimize (speed 3))) (let ((process *current-process*)) (declare (type process process)) (unless process (error "PROCESS-LOCK may not be called on the scheduler's stack group.")) (loop (unless (process-lock-locker lock) (return (setf (process-lock-locker lock) lock-value))) (push process (process-lock-waiting lock)) (let ((saved-whostate (process-whostate process))) (unwind-protect (progn (setf (process-whostate process) whostate) (process-add-arrest-reason process lock)) (setf (process-whostate process) saved-whostate)))))) #+clx-r4-process-patches (defun process-wait (whostate function &rest args) (declare (optimize (speed 3))) ;; Run the wait function once here both for efficiency and as a ;; first line check for errors in the function. (unless (apply function args) (process-wait-1 whostate function args))) #+clx-r4-process-patches (defun process-wait-1 (whostate function args) (declare (optimize (speed 3))) (let ((process *current-process*)) (declare (type process process)) (unless process (error "Process-wait may not be called within the scheduler's stack group.")) (let ((saved-whostate (process-whostate process))) (unwind-protect (without-scheduling-internal (without-interrupts (setf (process-whostate process) whostate (process-wait-function process) function (process-wait-args process) args) (chain-rem-q process) (chain-ins-q process *waiting-processes*)) (process-resume-scheduler nil)) (setf (process-whostate process) saved-whostate (process-wait-function process) nil (process-wait-args process) nil))))) #+clx-r4-process-patches (defun process-wait-with-timeout (whostate seconds function &rest args) ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. ;; -- 28Feb90 smh ;; Run the wait function once here both for efficiency and as a ;; first line check for errors in the function. (excl:if* (apply function args) then t else (let ((ret (list nil))) (without-interrupts (let ((clock-event (with-timeout-event seconds #'identity '(nil)))) (add-to-clock-queue clock-event) (process-wait-1 whostate #'(lambda (clock-event function args ret) (or (null (chain-next clock-event)) (and (apply function args) (setf (car ret) 't)))) (list clock-event function args ret)))) (car ret)))) ;; ;; Returns nil on timeout, otherwise t. ;; #+clx-r4-process-patches (defun wait-for-input-available (stream-or-fd &key (wait-function #'listen) (whostate "waiting for input") timeout) (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd elseif (streamp stream-or-fd) then (excl::stream-input-fn stream-or-fd) else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) ;; At this point fd could be nil, since stream-input-fn returns nil for ;; streams that are output only, or for certain special purpose streams. (if fd (unwind-protect (progn (mp::mpwatchfor fd) (excl:if* timeout then (mp::process-wait-with-timeout whostate timeout wait-function stream-or-fd) else (mp::process-wait whostate wait-function stream-or-fd) t)) (mp::mpunwatchfor fd)) (excl:if* timeout then (mp::process-wait-with-timeout whostate timeout wait-function stream-or-fd) else (mp::process-wait whostate wait-function stream-or-fd) t)))) cmucl-21a/src/clx/fonts.lisp000066400000000000000000000306551260377556400161710ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: fonts.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;; The char-info stuff is here instead of CLX because of uses of int16->card16. ; To allow efficient storage representations, the type char-info is not ; required to be a structure. ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: ;(defun char- (font index) ; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index ; ;; (or an in-bounds index on a pseudo font), although returning zero or ; ;; signalling might be better. ; (declare (type font font) ; (type integer index) ; (clx-values (or null integer)))) ;(defun max-char- (font) ; ;; Note: I have tentatively chosen separate accessors over allowing :min and ; ;; :max as an index above. ; (declare (type font font) ; (clx-values integer))) ;(defun min-char- (font) ; (declare (type font font) ; (clx-values integer))) ;; Note: char16- accessors could be defined to accept two-byte indexes. (deftype char-info-vec () '(simple-array int16 (*))) (macrolet ((def-char-info-accessors (useless-name &body fields) `(within-definition (,useless-name def-char-info-accessors) ,@(do ((field fields (cdr field)) (n 0 (1+ n)) (name) (type) (result nil)) ((endp field) result) (setq name (xintern 'char- (caar field))) (setq type (cadar field)) (flet ((from (form) (if (eq type 'int16) form `(,(xintern 'int16-> type) ,form)))) (push `(defun ,name (font index) (declare (type font font) (type array-index index)) (declare (clx-values (or null ,type))) (when (and (font-name font) (index>= (font-max-char font) index (font-min-char font))) (the ,type ,(from `(the int16 (let ((char-info-vector (font-char-infos font))) (declare (type char-info-vec char-info-vector)) (if (index-zerop (length char-info-vector)) ;; Fixed width font (aref (the char-info-vec (font-max-bounds font)) ,n) ;; Variable width font (aref char-info-vector (index+ (index* 6 (index- index (font-min-char font))) ,n))))))))) result) (setq name (xintern 'min-char- (caar field))) (push `(defun ,name (font) (declare (type font font)) (declare (clx-values (or null ,type))) (when (font-name font) (the ,type ,(from `(the int16 (aref (the char-info-vec (font-min-bounds font)) ,n)))))) result) (setq name (xintern 'max-char- (caar field))) (push `(defun ,name (font) (declare (type font font)) (declare (clx-values (or null ,type))) (when (font-name font) (the ,type ,(from `(the int16 (aref (the char-info-vec (font-max-bounds font)) ,n)))))) result))) (defun make-char-info (&key ,@(mapcar #'(lambda (field) `(,(car field) (required-arg ,(car field)))) fields)) (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) (let ((result (make-array ,(length fields) :element-type 'int16))) (declare (type char-info-vec result)) ,@(do* ((field fields (cdr field)) (var (caar field) (caar field)) (type (cadar field) (cadar field)) (n 0 (1+ n)) (result nil)) ((endp field) (nreverse result)) (push `(setf (aref result ,n) ,(if (eq type 'int16) var `(,(xintern type '->int16) ,var))) result)) result))))) (def-char-info-accessors ignore (left-bearing int16) (right-bearing int16) (width int16) (ascent int16) (descent int16) (attributes card16))) (defun open-font (display name) ;; Font objects may be cached and reference counted locally within the display ;; object. This function might not execute a with-display if the font is cached. ;; The protocol QueryFont request happens on-demand under the covers. (declare (type display display) (type stringable name)) (declare (clx-values font)) (let* ((name-string (string-downcase (string name))) (font (car (member name-string (display-font-cache display) :key 'font-name :test 'equal))) font-id) (unless font (setq font (make-font :display display :name name-string)) (setq font-id (allocate-resource-id display font 'font)) (setf (font-id-internal font) font-id) (with-buffer-request (display +x-openfont+) (resource-id font-id) (card16 (length name-string)) (pad16 nil) (string name-string)) (push font (display-font-cache display))) (incf (font-reference-count font)) (unless (font-font-info-internal font) (query-font font)) font)) (defun open-font-internal (font) ;; Called "under the covers" to open a font object (declare (type font font)) (declare (clx-values resource-id)) (let* ((name-string (font-name font)) (display (font-display font)) (id (allocate-resource-id display font 'font))) (setf (font-id-internal font) id) (with-buffer-request (display +x-openfont+) (resource-id id) (card16 (length name-string)) (pad16 nil) (string name-string)) (push font (display-font-cache display)) (incf (font-reference-count font)) id)) (defun discard-font-info (font) ;; Discards any state that can be re-obtained with QueryFont. This is ;; simply a performance hint for memory-limited systems. (declare (type font font)) (setf (font-font-info-internal font) nil (font-char-infos-internal font) nil)) (defun query-font (font) ;; Internal function called by font and char info accessors (declare (type font font)) (declare (clx-values font-info)) (let ((display (font-display font)) font-id font-info props) (setq font-id (font-id font)) ;; May issue an open-font request (with-buffer-request-and-reply (display +x-queryfont+ 60) ((resource-id font-id)) (let* ((min-byte2 (card16-get 40)) (max-byte2 (card16-get 42)) (min-byte1 (card8-get 49)) (max-byte1 (card8-get 50)) (min-char min-byte2) (max-char (index+ (index-ash max-byte1 8) max-byte2)) (nfont-props (card16-get 46)) (nchar-infos (index* (card32-get 56) 6)) (char-info (make-array nchar-infos :element-type 'int16))) (setq font-info (make-font-info :direction (member8-get 48 :left-to-right :right-to-left) :min-char min-char :max-char max-char :min-byte1 min-byte1 :max-byte1 max-byte1 :min-byte2 min-byte2 :max-byte2 max-byte2 :all-chars-exist-p (boolean-get 51) :default-char (card16-get 44) :ascent (int16-get 52) :descent (int16-get 54) :min-bounds (char-info-get 8) :max-bounds (char-info-get 24))) (setq props (sequence-get :length (index* 2 nfont-props) :format int32 :result-type 'list :index 60)) (sequence-get :length nchar-infos :format int16 :data char-info :index (index+ 60 (index* 2 nfont-props 4))) (setf (font-char-infos-internal font) char-info) (setf (font-font-info-internal font) font-info))) ;; Replace atom id's with keywords in the plist (do ((p props (cddr p))) ((endp p)) (setf (car p) (atom-name display (car p)))) (setf (font-info-properties font-info) props) font-info)) (defun close-font (font) ;; This might not generate a protocol request if the font is reference ;; counted locally. (declare (type font font)) (when (and (not (plusp (decf (font-reference-count font)))) (font-id-internal font)) (let ((display (font-display font)) (id (font-id-internal font))) (declare (type display display)) ;; Remove font from cache (setf (display-font-cache display) (delete font (display-font-cache display))) ;; Close the font (with-buffer-request (display +x-closefont+) (resource-id id))))) (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) (declare (type display display) (type string pattern) (type card16 max-fonts) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (let ((string (string pattern))) (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16)) ((card16 max-fonts (length string)) (string string)) (values (read-sequence-string buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))) (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) ;; Note: Was called list-fonts-with-info. ;; Returns "pseudo" fonts that contain basic font metrics and properties, but ;; no per-character metrics and no resource-ids. These pseudo fonts will be ;; converted (internally) to real fonts dynamically as needed, by issuing an ;; OpenFont request. However, the OpenFont might fail, in which case the ;; invalid-font error can arise. (declare (type display display) (type string pattern) (type card16 max-fonts) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence font))) (let ((string (string pattern)) (result nil)) (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60 :sizes (8 16) :multiple-reply t) ((card16 max-fonts (length string)) (string string)) (cond ((zerop (card8-get 1)) t) (t (let* ((name-len (card8-get 1)) (min-byte2 (card16-get 40)) (max-byte2 (card16-get 42)) (min-byte1 (card8-get 49)) (max-byte1 (card8-get 50)) (min-char min-byte2) (max-char (index+ (index-ash max-byte1 8) max-byte2)) (nfont-props (card16-get 46)) (font (make-font :display display :name nil :font-info-internal (make-font-info :direction (member8-get 48 :left-to-right :right-to-left) :min-char min-char :max-char max-char :min-byte1 min-byte1 :max-byte1 max-byte1 :min-byte2 min-byte2 :max-byte2 max-byte2 :all-chars-exist-p (boolean-get 51) :default-char (card16-get 44) :ascent (int16-get 52) :descent (int16-get 54) :min-bounds (char-info-get 8) :max-bounds (char-info-get 24) :properties (sequence-get :length (index* 2 nfont-props) :format int32 :result-type 'list :index 60))))) (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) (push font result)) nil))) ;; Replace atom id's with keywords in the plist (dolist (font result) (do ((p (font-properties font) (cddr p))) ((endp p)) (setf (car p) (atom-name display (car p))))) (coerce (nreverse result) result-type))) (defun font-path (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence (or string pathname)))) (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16)) () (values (read-sequence-string buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))) (defun set-font-path (display paths) (declare (type display display) (type (clx-sequence (or string pathname)) paths)) (let ((path-length (length paths)) (request-length 8)) ;; Find the request length (dotimes (i path-length) (let* ((string (string (elt paths i))) (len (length string))) (incf request-length (1+ len)))) (with-buffer-request (display +x-setfontpath+ :length request-length) (length (ceiling request-length 4)) (card16 path-length) (pad16 nil) (progn (incf buffer-boffset 8) (dotimes (i path-length) (let* ((string (string (elt paths i))) (len (length string))) (card8-put 0 len) (string-put 1 string :appending t :header-length 1) (incf buffer-boffset (1+ len)))) (setf (buffer-boffset display) (lround buffer-boffset))))) paths) (defsetf font-path set-font-path) cmucl-21a/src/clx/gcontext.lisp000066400000000000000000001207341260377556400166710ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; GContext ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; GContext values are usually cached locally in the GContext object. ;;; This is required because the X.11 server doesn't have any requests ;;; for getting GContext values back. ;;; ;;; GContext changes are cached until force-GContext-changes is called. ;;; All the requests that use GContext (including the GContext accessors, ;;; but not the SETF's) call force-GContext-changes. ;;; In addition, the macro WITH-GCONTEXT may be used to provide a ;;; local view if a GContext. ;;; ;;; Each GContext keeps a copy of the values the server has seen, and ;;; a copy altered by SETF, called the LOCAL-STATE (bad name...). ;;; The SETF accessors increment a timestamp in the GContext. ;;; When the timestamp in a GContext isn't equal to the timestamp in ;;; the local-state, changes have been made, and force-GContext-changes ;;; loops through the GContext and local-state, sending differences to ;;; the server, and updating GContext. ;;; ;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to ;;; a private copy. This is easy (and fast) for lisp machines, but other ;;; lisps will have problems. Fortunately, most other lisps don't care, ;;; because they don't run in a multi-processing shared-address space ;;; environment. #+cmu (ext:file-comment "$Id: gcontext.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;; GContext state accessors ;; The state vector contains all card32s to speed server updating (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+)) (macrolet ((def-gc-internals (name &rest extras) (let ((macros nil) (indexes nil) (masks nil) (index 0)) (dolist (name +gcontext-components+) (push `(defmacro ,(xintern 'gcontext-internal- name) (state) `(svref ,state ,,index)) macros) (setf (getf indexes name) index) (push (ash 1 index) masks) (incf index)) (dolist (extra extras) (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) `(svref ,state ,,index)) macros) ;; don't override already correct index entries (unless (or (getf indexes (second extra)) (getf indexes (first extra))) (setf (getf indexes (or (second extra) (first extra))) index)) (push (logior (ash 1 index) (if (second extra) (ash 1 (position (second extra) +gcontext-components+)) 0)) masks) (incf index)) `(within-definition (def-gc-internals ,name) ,@(nreverse macros) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *gcontext-data-length* ,index) (defvar *gcontext-indexes* ',indexes) (defvar *gcontext-masks* ',(coerce (nreverse masks) 'simple-vector) )))))) (def-gc-internals ignore (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) ) ;; end EVAL-WHEN (deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+)) (deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*)) (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named (name nil :type symbol :read-only t) (default nil :type t :read-only t) ;; FIXME: these used to have glorious, but wrong, type declarations. ;; See if we can't return them to their former glory. (set-function #'(lambda (gcontext value) (declare (ignore gcontext)) value) :type (or function symbol) :read-only t) (copy-function #'(lambda (from-gc to-gc value) (declare (ignore from-gc to-gc)) value) :type (or function symbol) :read-only t)) (defvar *gcontext-extensions* nil) ;; list of gcontext-extension ;; Gcontext state Resource (defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states (defmacro gcontext-state-next (state) `(svref ,state 0)) (defun allocate-gcontext-state () ;; Allocate a gcontext-state ;; Loop until a local state is found that's large enough to hold ;; any extensions that may exist. (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*)))) (declare (type array-index length)) (loop (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache* gcontext-state-next gcontext-state) (make-array length :initial-element nil)))) (declare (type gcontext-state state)) (when (index>= (length state) length) (return state)))))) (defun deallocate-gcontext-state (state) (declare (type gcontext-state state)) (fill state nil) (threaded-atomic-push state *gcontext-local-state-cache* gcontext-state-next gcontext-state)) ;; Temp-Gcontext Resource (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts (defun allocate-temp-gcontext () (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext) (make-gcontext :local-state '#() :server-state '#()))) (defun deallocate-temp-gcontext (gc) (declare (type gcontext gc)) (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext)) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type ), there is an accessor: ;(defun gcontext- (gcontext) ; ;; The value will be nil if the last value stored is unknown (e.g., the cache was ; ;; off, or the component was copied from a gcontext with unknown state). ; (declare (type gcontext gcontext) ; (clx-values ))) ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared ;; as (type (or null ) ), there is a setf for the corresponding accessor: ;(defsetf gcontext- (gcontext) (value) ; ) ;; Generate all the accessors and defsetf's for GContext (defmacro xgcmask->gcmask (mask) `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+))))) (defmacro access-gcontext ((gcontext local-state) &body body) `(let ((,local-state (gcontext-local-state ,gcontext))) (declare (type gcontext-state ,local-state)) ,@body)) (defmacro modify-gcontext ((gcontext local-state) &body body) ;; The timestamp must be altered after the modification `(let ((,local-state (gcontext-local-state ,gcontext))) (declare (type gcontext-state ,local-state)) (prog1 (progn ,@body) (setf (gcontext-internal-timestamp ,local-state) 0)))) (defmacro def-gc-accessor (name type) (let* ((gcontext-name (xintern 'gcontext- name)) (internal-accessor (xintern 'gcontext-internal- name)) (internal-setfer (xintern 'set- gcontext-name))) `(within-definition (,name def-gc-accessor) (defun ,gcontext-name (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null ,type))) (let ((value (,internal-accessor (gcontext-local-state gcontext)))) (declare (type (or null card32) value)) (when value ;; Don't do anything when value isn't known (let ((%buffer (gcontext-display gcontext))) (declare (type display %buffer)) %buffer (decode-type ,type value))))) (defun ,internal-setfer (gcontext value) (declare (type gcontext gcontext) (type ,type value)) (modify-gcontext (gcontext local-state) (setf (,internal-accessor local-state) (encode-type ,type value)) ,@(when (eq type 'pixmap) ;; write-through pixmaps, because the protocol allows ;; the server to copy the pixmap contents at the time ;; of the store, rather than continuing to share with ;; the pixmap. `((let ((server-state (gcontext-server-state gcontext))) (setf (,internal-accessor server-state) nil)))) value)) (defsetf ,gcontext-name ,internal-setfer)))) (defmacro incf-internal-timestamp (state) (let ((ts (gensym))) `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state)))) (declare (type fixnum ,ts)) ;; the probability seems low enough (setq ,ts (if (= ,ts most-positive-fixnum) 1 (the fixnum (1+ ,ts)))) (setf (gcontext-internal-timestamp ,state) ,ts)))) (def-gc-accessor function boole-constant) (def-gc-accessor plane-mask card32) (def-gc-accessor foreground card32) (def-gc-accessor background card32) (def-gc-accessor line-width card16) (def-gc-accessor line-style (member :solid :dash :double-dash)) (def-gc-accessor cap-style (member :not-last :butt :round :projecting)) (def-gc-accessor join-style (member :miter :round :bevel)) (def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled)) (def-gc-accessor fill-rule (member :even-odd :winding)) (def-gc-accessor tile pixmap) (def-gc-accessor stipple pixmap) (def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin (def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin ;; (def-GC-accessor font font) ;; See below (def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors)) (def-gc-accessor exposures (member :off :on)) (def-gc-accessor clip-x int16) (def-gc-accessor clip-y int16) ;; (def-GC-accessor clip-mask) ;; see below (def-gc-accessor dash-offset card16) ;; (def-GC-accessor dashes) ;; see below (def-gc-accessor arc-mode (member :chord :pie-slice)) (defun gcontext-clip-mask (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null (member :none) pixmap rect-seq) (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))) (access-gcontext (gcontext local-state) (multiple-value-bind (clip clip-mask) (without-interrupts (values (gcontext-internal-clip local-state) (gcontext-internal-clip-mask local-state))) (if (null clip) (values (let ((%buffer (gcontext-display gcontext))) (declare (type display %buffer)) (decode-type (or (member :none) pixmap) clip-mask)) nil) (values (second clip) (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) (first clip))))))) (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask) ;; A bit strange, but retains setf form. ;; a nil clip-mask is transformed to an empty vector `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask)) (defun set-gcontext-clip-mask (gcontext ordering clip-mask) ;; a nil clip-mask is transformed to an empty vector (declare (type gcontext gcontext) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) (type (or (member :none) pixmap rect-seq) clip-mask)) (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq))) (multiple-value-bind (clip-mask clip) (typecase clip-mask (pixmap (values (pixmap-id clip-mask) nil)) ((member :none) (values 0 nil)) (sequence (values nil (list (encode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering) (copy-seq clip-mask)))) (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-clip local-state) clip (gcontext-internal-clip-mask local-state) clip-mask) (if (null clip) (setf (gcontext-internal-clip server-state) nil) (setf (gcontext-internal-clip-mask server-state) nil)) (when (and clip-mask (not (zerop clip-mask))) ;; write-through clip-mask pixmap, because the protocol allows the ;; server to copy the pixmap contents at the time of the store, ;; rather than continuing to share with the pixmap. (setf (gcontext-internal-clip-mask server-state) nil)))))) clip-mask) (defun gcontext-dashes (gcontext) (declare (type gcontext gcontext)) (declare (clx-values (or null card8 sequence))) (access-gcontext (gcontext local-state) (multiple-value-bind (dash dashes) (without-interrupts (values (gcontext-internal-dash local-state) (gcontext-internal-dashes local-state))) (if (null dash) dashes dash)))) (defsetf gcontext-dashes set-gcontext-dashes) (defun set-gcontext-dashes (gcontext dashes) (declare (type gcontext gcontext) (type (or card8 sequence) dashes)) (multiple-value-bind (dashes dash) (if (type? dashes 'sequence) (if (zerop (length dashes)) (x-type-error dashes '(or card8 sequence) "non-empty sequence") (values nil (or (copy-seq dashes) (vector)))) (values (encode-type card8 dashes) nil)) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-dash local-state) dash (gcontext-internal-dashes local-state) dashes) (if (null dash) (setf (gcontext-internal-dash server-state) nil) (setf (gcontext-internal-dashes server-state) nil)))))) dashes) (defun gcontext-font (gcontext &optional metrics-p) ;; If the stored font is known, it is returned. If it is not known and ;; metrics-p is false, then nil is returned. If it is not known and ;; metrics-p is true, then a pseudo font is returned. Full metric and ;; property information can be obtained, but the font does not have a name or ;; a resource-id, and attempts to use it where a resource-id is required will ;; result in an invalid-font error. (declare (type gcontext gcontext) (type generalized-boolean metrics-p)) (declare (clx-values (or null font))) (access-gcontext (gcontext local-state) (let ((font (gcontext-internal-font-obj local-state))) (or font (when metrics-p ;; XXX this isn't correct (make-font :display (gcontext-display gcontext) :id (gcontext-id gcontext) :name nil)))))) (defsetf gcontext-font set-gcontext-font) (defun set-gcontext-font (gcontext font) (declare (type gcontext gcontext) (type fontable font)) (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))) (font (and font-object (font-id font-object)))) ;; XXX need to check font has id (and name?) (modify-gcontext (gcontext local-state) (let ((server-state (gcontext-server-state gcontext))) (declare (type gcontext-state server-state)) (without-interrupts (setf (gcontext-internal-font-obj local-state) font-object (gcontext-internal-font local-state) font) ;; check against font, not against font-obj (if (null font) (setf (gcontext-internal-font server-state) nil) (setf (gcontext-internal-font-obj server-state) font-object)))))) font) (defun force-gcontext-changes-internal (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) #.(declare-buffun) (let ((display (gcontext-display gcontext)) (server-state (gcontext-server-state gcontext)) (local-state (gcontext-local-state gcontext))) (declare (type display display) (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) (the fixnum (gcontext-internal-timestamp server-state))) ;; The display is already locked. (macrolet ((with-buffer ((buffer &key timeout) &body body) `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil) ,@body))) ;; Because there is no locking on the local state we have to ;; assume that state will change and set timestamps up front, ;; otherwise by the time we figured out there were no changes ;; and tried to store the server stamp as the local stamp, the ;; local stamp might have since been modified. (setf (gcontext-internal-timestamp local-state) (incf-internal-timestamp server-state)) (block no-changes (let ((last-request (buffer-last-request display))) (with-buffer-request (display +x-changegc+) (gcontext gcontext) (progn (do ((i 0 (index+ i 1)) (bit 1 (the xgcmask (ash bit 1))) (nbyte 12) (mask 0) (local 0)) ((index>= i +gcontext-fast-change-length+) (when (zerop mask) ;; If nothing changed, restore last-request and quit (setf (buffer-last-request display) (if (zerop (buffer-last-request display)) nil last-request)) (return-from no-changes nil)) (card29-put 8 mask) (card16-put 2 (index-ash nbyte -2)) (index-incf (buffer-boffset display) nbyte)) (declare (type array-index i nbyte) (type xgcmask bit) (type gcmask mask) (type (or null card32) local)) (unless (eql (the (or null card32) (svref server-state i)) (setq local (the (or null card32) (svref local-state i)))) (setf (svref server-state i) local) (card32-put nbyte local) (setq mask (the gcmask (logior mask bit))) (index-incf nbyte 4))))))) ;; Update GContext extensions (do ((extension *gcontext-extensions* (cdr extension)) (i *gcontext-data-length* (index+ i 1)) (local)) ((endp extension)) (unless (eql (svref server-state i) (setq local (svref local-state i))) (setf (svref server-state i) local) (funcall (gcontext-extension-set-function (car extension)) gcontext local))) ;; Update clipping rectangles (multiple-value-bind (local-clip server-clip) (without-interrupts (values (gcontext-internal-clip local-state) (gcontext-internal-clip server-state))) (unless (equalp local-clip server-clip) (setf (gcontext-internal-clip server-state) nil) (unless (null local-clip) (with-buffer-request (display +x-setcliprectangles+) (data (first local-clip)) (gcontext gcontext) ;; XXX treat nil correctly (card16 (or (gcontext-internal-clip-x local-state) 0) (or (gcontext-internal-clip-y local-state) 0)) ;; XXX this has both int16 and card16 values ((sequence :format int16) (second local-clip))) (setf (gcontext-internal-clip server-state) local-clip)))) ;; Update dashes (multiple-value-bind (local-dash server-dash) (without-interrupts (values (gcontext-internal-dash local-state) (gcontext-internal-dash server-state))) (unless (equalp local-dash server-dash) (setf (gcontext-internal-dash server-state) nil) (unless (null local-dash) (with-buffer-request (display +x-setdashes+) (gcontext gcontext) ;; XXX treat nil correctly (card16 (or (gcontext-internal-dash-offset local-state) 0) (length local-dash)) ((sequence :format card8) local-dash)) (setf (gcontext-internal-dash server-state) local-dash)))))))) (defun force-gcontext-changes (gcontext) ;; Force any delayed changes. (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext)) (server-state (gcontext-server-state gcontext)) (local-state (gcontext-local-state gcontext))) (declare (type gcontext-state server-state local-state)) ;; Update server when timestamps don't match (unless (= (the fixnum (gcontext-internal-timestamp local-state)) (the fixnum (gcontext-internal-timestamp server-state))) (with-display (display) (force-gcontext-changes-internal gcontext))))) ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE ;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN ;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN ;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS ;;; BACK. (defmacro with-gcontext ((gcontext &rest options &key clip-ordering &allow-other-keys) &body body) ;; "Binds" the gcontext components specified by options within the ;; dynamic scope of the body (i.e., indefinite scope and dynamic ;; extent), on a per-process basis in a multi-process environment. ;; The body is not surrounded by a with-display. If cache-p is nil or ;; the some component states are unknown, this will implement ;; save/restore by creating a temporary gcontext and doing ;; copy-gcontext-components to and from it. (declare (arglist (gcontext &rest options &key function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes &allow-other-keys) &body body)) (remf options :clip-ordering) (let ((gc (gensym)) (saved-state (gensym)) (temp-gc (gensym)) (temp-mask (gensym)) (temp-vars nil) (setfs nil) (indexes nil) ; List of gcontext field indices (extension-indexes nil) ; List of gcontext extension field indices (ts-index (getf *gcontext-indexes* :timestamp))) (do* ((option options (cddr option)) (name (car option) (car option)) (value (cadr option) (cadr option))) ((endp option) (setq setfs (nreverse setfs))) (let ((index (getf *gcontext-indexes* name))) (if index (push index indexes) (let ((extension (find name *gcontext-extensions* :key #'gcontext-extension-name))) (if extension (progn (push (xintern "Internal-" 'gcontext- name "-State-Index") extension-indexes)) (x-type-error name 'gcontext-key))))) (let ((accessor `(,(xintern 'gcontext- name) ,gc ,@(when (eq name :clip-mask) `(,clip-ordering)))) (temp-var (gensym))) (when value (push `(,temp-var ,value) temp-vars) (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs)))) (if setfs `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) (declare (type gcontext ,gc) (type gcontext-state ,saved-state) (type xgcmask ,temp-mask) (type (or null gcontext) ,temp-gc)) (with-gcontext-bindings (,gc ,saved-state ,(append indexes extension-indexes) ,ts-index ,temp-mask ,temp-gc) (let ,temp-vars ,@setfs) ,@body)) `(progn ,@body)))) (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices) ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK (declare (type gcontext gcontext) (type list indexes) (dynamic-extent extension-indices)) (let ((local-state (gcontext-local-state gcontext)) (saved-state (allocate-gcontext-state)) (cache-p (gcontext-cache-p gcontext))) (declare (type gcontext-state local-state saved-state)) (setf (gcontext-internal-timestamp saved-state) 1) (let ((temp-gc nil) (temp-mask 0) (extension-mask 0)) (declare (type xgcmask temp-mask) (type integer extension-mask)) (dolist (i indexes) (when (or (not (setf (svref saved-state i) (svref local-state i))) (not cache-p)) (setq temp-mask (the xgcmask (logior temp-mask (the xgcmask (svref *gcontext-masks* i))))))) (dolist (i extension-indices) (when (or (not (setf (svref saved-state i) (svref local-state i))) (not cache-p)) (setq extension-mask (the xgcmask (logior extension-mask (ash 1 i)))))) (when (or (plusp temp-mask) (plusp extension-mask)) ;; Copy to temporary GC when field unknown or cache-p false (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) (setq temp-gc (allocate-temp-gcontext)) (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext) (gcontext-display temp-gc) display (gcontext-drawable temp-gc) (gcontext-drawable gcontext) (gcontext-server-state temp-gc) saved-state (gcontext-local-state temp-gc) saved-state) ;; Create a new (temporary) gcontext (with-buffer-request (display +x-creategc+) (gcontext temp-gc) (drawable (gcontext-drawable gcontext)) (card29 0)) ;; Copy changed components to the temporary gcontext (when (plusp temp-mask) (with-buffer-request (display +x-copygc+) (gcontext gcontext) (gcontext temp-gc) (card29 (xgcmask->gcmask temp-mask)))) ;; Copy extension fields to the new gcontext (when (plusp extension-mask) ;; Copy extension fields from temp back to gcontext (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1)) (i 0 (index+ i 1))) ((zerop bit)) (let ((copy-function (gcontext-extension-copy-function (elt *gcontext-extensions* i)))) (funcall copy-function gcontext temp-gc (svref local-state (index+ i *gcontext-data-length*)))))) ))) (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc) (declare (type gcontext gcontext temp-gc) (type xgcmask temp-mask)) (let ((display (gcontext-display gcontext))) (declare (type display display)) (with-display (display) (with-buffer-request (display +x-copygc+) (gcontext temp-gc) (gcontext gcontext) (card29 (xgcmask->gcmask temp-mask))) ;; Copy extension fields from temp back to gcontext (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1)) (extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1)) (local-state (gcontext-local-state temp-gc))) ((zerop bit)) (let ((copy-function (gcontext-extension-copy-function (car extensions)))) (funcall copy-function temp-gc gcontext (svref local-state i)))) ;; free gcontext (with-buffer-request (display +x-freegc+) (gcontext temp-gc)) (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext) (deallocate-temp-gcontext temp-gc) ;; Copy saved state back to server state (do ((server-state (gcontext-server-state gcontext)) (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1))) (i 0 (index+ i 1))) ((zerop bit) (incf-internal-timestamp server-state)) (declare (type gcontext-state server-state) (type gcmask bit) (type array-index i)) (when (oddp bit) (setf (svref server-state i) nil)))))) (defun create-gcontext (&rest options &key (drawable (required-arg drawable)) function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes (cache-p t) &allow-other-keys) ;; Only non-nil components are passed on in the request, but for effective caching ;; assumptions have to be made about what the actual protocol defaults are. For ;; all gcontext components, a value of nil causes the default gcontext value to be ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented ;; as a list. Note: use of stringable as font will cause an implicit open-font. ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext ;; component will have no effect unless the new value differs from the cached ;; value. Component changes (setfs and with-gcontext) are always deferred ;; regardless of the cache mode, and sent over the protocol only when required by a ;; local operation or by an explicit call to force-gcontext-changes. (declare (type drawable drawable) ; Required to be non-null (type (or null boole-constant) function) (type (or null pixel) plane-mask foreground background) (type (or null card16) line-width dash-offset) (type (or null int16) ts-x ts-y clip-x clip-y) (type (or null (member :solid :dash :double-dash)) line-style) (type (or null (member :not-last :butt :round :projecting)) cap-style) (type (or null (member :miter :round :bevel)) join-style) (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style) (type (or null (member :even-odd :winding)) fill-rule) (type (or null (member :chord :pie-slice)) arc-mode) (type (or null pixmap) tile stipple) (type (or null fontable) font) (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode) (type (or null (member :on :off)) exposures) (type (or null (member :none) pixmap rect-seq) clip-mask) (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering) (type (or null card8 sequence) dashes) (dynamic-extent options) (type generalized-boolean cache-p)) (declare (clx-values gcontext)) (let* ((display (drawable-display drawable)) (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p)) (local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext)) (gcontextid (allocate-resource-id display gcontext 'gcontext))) (declare (type display display) (type gcontext gcontext) (type resource-id gcontextid) (type gcontext-state local-state server-state)) (setf (gcontext-id gcontext) gcontextid) (unless function (setf (gcontext-function gcontext) boole-1)) ;; using the depth of the drawable would be better, but ... (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff)) (unless foreground (setf (gcontext-foreground gcontext) 0)) (unless background (setf (gcontext-background gcontext) 1)) (unless line-width (setf (gcontext-line-width gcontext) 0)) (unless line-style (setf (gcontext-line-style gcontext) :solid)) (unless cap-style (setf (gcontext-cap-style gcontext) :butt)) (unless join-style (setf (gcontext-join-style gcontext) :miter)) (unless fill-style (setf (gcontext-fill-style gcontext) :solid)) (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd)) (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice)) (unless ts-x (setf (gcontext-ts-x gcontext) 0)) (unless ts-y (setf (gcontext-ts-y gcontext) 0)) (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext) :clip-by-children)) (unless exposures (setf (gcontext-exposures gcontext) :on)) (unless clip-mask (setf (gcontext-clip-mask gcontext) :none)) (unless clip-x (setf (gcontext-clip-x gcontext) 0)) (unless clip-y (setf (gcontext-clip-y gcontext) 0)) (unless dashes (setf (gcontext-dashes gcontext) 4)) (unless dash-offset (setf (gcontext-dash-offset gcontext) 0)) ;; a bit kludgy, but ... (replace server-state local-state) (when function (setf (gcontext-function gcontext) function)) (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask)) (when foreground (setf (gcontext-foreground gcontext) foreground)) (when background (setf (gcontext-background gcontext) background)) (when line-width (setf (gcontext-line-width gcontext) line-width)) (when line-style (setf (gcontext-line-style gcontext) line-style)) (when cap-style (setf (gcontext-cap-style gcontext) cap-style)) (when join-style (setf (gcontext-join-style gcontext) join-style)) (when fill-style (setf (gcontext-fill-style gcontext) fill-style)) (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule)) (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode)) (when tile (setf (gcontext-tile gcontext) tile)) (when stipple (setf (gcontext-stipple gcontext) stipple)) (when ts-x (setf (gcontext-ts-x gcontext) ts-x)) (when ts-y (setf (gcontext-ts-y gcontext) ts-y)) (when font (setf (gcontext-font gcontext) font)) (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) (when exposures (setf (gcontext-exposures gcontext) exposures)) (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) (when dashes (setf (gcontext-dashes gcontext) dashes)) (setf (gcontext-internal-timestamp server-state) 1) (setf (gcontext-internal-timestamp local-state) ;; SetClipRectangles or SetDashes request need to be sent? (if (or (gcontext-internal-clip local-state) (gcontext-internal-dash local-state)) ;; Yes, mark local state "modified" to ensure ;; force-gcontext-changes will occur. 0 ;; No, mark local state "unmodified" 1)) (with-buffer-request (display +x-creategc+) (resource-id gcontextid) (drawable drawable) (progn (do* ((i 0 (index+ i 1)) (bit 1 (the xgcmask (ash bit 1))) (nbyte 16) (mask 0) (local (svref local-state i) (svref local-state i))) ((index>= i +gcontext-fast-change-length+) (card29-put 12 mask) (card16-put 2 (index-ash nbyte -2)) (index-incf (buffer-boffset display) nbyte)) (declare (type array-index i nbyte) (type xgcmask bit) (type gcmask mask) (type (or null card32) local)) (unless (eql local (the (or null card32) (svref server-state i))) (setf (svref server-state i) local) (card32-put nbyte local) (setq mask (the gcmask (logior mask bit))) (index-incf nbyte 4))))) ;; Initialize extensions (do ((extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1))) ((endp extensions)) (declare (type list extensions) (type array-index i)) (setf (svref server-state i) (setf (svref local-state i) (gcontext-extension-default (car extensions))))) ;; Set extension values (do* ((option-list options (cddr option-list)) (option (car option-list) (car option-list)) (extension)) ((endp option-list)) (declare (type list option-list)) (cond ((getf *gcontext-indexes* option)) ; Gcontext field ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter ((setq extension (find option *gcontext-extensions* :key #'gcontext-extension-name)) (funcall (gcontext-extension-set-function extension) gcontext (second option-list))) (t (x-type-error option 'gcontext-key)))) gcontext)) (defun copy-gcontext-components (src dst &rest keys) (declare (type gcontext src dst) (dynamic-extent keys)) ;; you might ask why this isn't just a bunch of ;; (setf (gcontext- dst) (gcontext- src)) ;; the answer is that you can do that yourself if you want, what we are ;; providing here is access to the protocol request, which will generally ;; be more efficient (particularly for things like clip and dash lists). (when keys (let ((display (gcontext-display src)) (mask 0)) (declare (type xgcmask mask)) (with-display (display) (force-gcontext-changes-internal src) (force-gcontext-changes-internal dst) ;; collect entire mask and handle extensions (dolist (key keys) (let ((i (getf *gcontext-indexes* key))) (declare (type (or null array-index) i)) (if i (setq mask (the xgcmask (logior mask (the xgcmask (svref *gcontext-masks* i))))) (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name))) (if extension (funcall (gcontext-extension-copy-function extension) src dst (svref (gcontext-local-state src) (index+ (position extension *gcontext-extensions*) *gcontext-data-length*))) (x-type-error key 'gcontext-key)))))) (when (plusp mask) (do ((src-server-state (gcontext-server-state src)) (dst-server-state (gcontext-server-state dst)) (dst-local-state (gcontext-local-state dst)) (bit mask (the xgcmask (ash bit -1))) (i 0 (index+ i 1))) ((zerop bit) (incf-internal-timestamp dst-server-state) (setf (gcontext-internal-timestamp dst-local-state) 0)) (declare (type gcontext-state src-server-state dst-server-state dst-local-state) (type xgcmask bit) (type array-index i)) (when (oddp bit) (setf (svref dst-local-state i) (setf (svref dst-server-state i) (svref src-server-state i))))) (with-buffer-request (display +x-copygc+) (gcontext src dst) (card29 (xgcmask->gcmask mask)))))))) (defun copy-gcontext (src dst) (declare (type gcontext src dst)) ;; Copies all components. (apply #'copy-gcontext-components src dst +gcontext-components+) (do ((extensions *gcontext-extensions* (cdr extensions)) (i *gcontext-data-length* (index+ i 1))) ((endp extensions)) (funcall (gcontext-extension-copy-function (car extensions)) src dst (svref (gcontext-local-state src) i)))) (defun free-gcontext (gcontext) (declare (type gcontext gcontext)) (let ((display (gcontext-display gcontext))) (with-buffer-request (display +x-freegc+) (gcontext gcontext)) (deallocate-resource-id display (gcontext-id gcontext) 'gcontext) (deallocate-gcontext-state (gcontext-server-state gcontext)) (deallocate-gcontext-state (gcontext-local-state gcontext)) nil)) (defmacro define-gcontext-accessor (name &key default set-function copy-function) ;; This will define a new gcontext accessor called NAME. ;; Defines the gcontext-NAME accessor function and its defsetf. ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when ;; gcontext-cache-p is true. The NAME keyword will be allowed in ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS. ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE) ;; from create-gcontext, and force-gcontext-changes. ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value) ;; from copy-gcontext and copy-gcontext-components. ;; The copy-function defaults to: ;; (lambda (ignore dst-gc value) ;; (if value ;; (,set-function dst-gc value) ;; (error "Can't copy unknown GContext component ~a" ',name))) (declare (type symbol name) (type t default) (type symbol set-function) ;; required (type (or symbol list) copy-function)) (let* ((gc-name (intern (concatenate 'string (string 'gcontext-) (string name)))) ;; in current package (key-name (kintern name)) (setfer (xintern "Set-" gc-name)) (internal-set-function (xintern "Internal-Set-" gc-name)) (internal-copy-function (xintern "Internal-Copy-" gc-name)) (internal-state-index (xintern "Internal-" gc-name "-State-Index"))) (unless copy-function (setq copy-function `(lambda (src-gc dst-gc value) (declare (ignore src-gc)) (if value (,set-function dst-gc value) (error "Can't copy unknown GContext component ~a" ',name))))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter ,internal-state-index (add-gcontext-extension ',key-name ,default ',internal-set-function ',internal-copy-function)) ) ;; end eval-when (defun ,gc-name (gcontext) (svref (gcontext-local-state gcontext) ,internal-state-index)) (defun ,setfer (gcontext new-value) (let ((local-state (gcontext-local-state gcontext))) (setf (gcontext-internal-timestamp local-state) 0) (setf (svref local-state ,internal-state-index) new-value))) (defsetf ,gc-name ,setfer) (defun ,internal-set-function (gcontext new-value) (,set-function gcontext new-value) (setf (svref (gcontext-server-state gcontext) ,internal-state-index) (setf (svref (gcontext-local-state gcontext) ,internal-state-index) new-value))) (defun ,internal-copy-function (src-gc dst-gc new-value) (,copy-function src-gc dst-gc new-value) (setf (svref (gcontext-local-state dst-gc) ,internal-state-index) (setf (svref (gcontext-server-state dst-gc) ,internal-state-index) new-value))) ',name))) ;; GContext extension fields are treated in much the same way as normal GContext ;; components. The current value is stored in a slot of the gcontext-local-state, ;; and the value known to the server is in a slot of the gcontext-server-state. ;; The slot-number is defined by its position in the *gcontext-extensions* list. ;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is ;; the extension component name) reflects this position. The position within ;; *gcontext-extensions* and the value of the special value are determined at ;; LOAD time to facilitate merging of seperately compiled extension files. (defun add-gcontext-extension (name default-value set-function copy-function) (declare (type symbol name) (type t default-value) (type (or function symbol) set-function) (type (or function symbol) copy-function)) (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name) (prog1 (length *gcontext-extensions*) (push nil *gcontext-extensions*))))) (setf (nth number *gcontext-extensions*) (make-gcontext-extension :name name :default default-value :set-function set-function :copy-function copy-function)) (+ number *gcontext-data-length*))) cmucl-21a/src/clx/generalock.lisp000066400000000000000000000062541260377556400171500ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- ;;; Copyright (C) 1990 Symbolics, Inc. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Symbolics, Inc. provides this software "as is" without ;;; express or implied warranty. #+cmu (ext:file-comment "$Id: generalock.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") (defflavor xlib::clx-lock () (simple-recursive-normal-lock) (:init-keywords :flavor)) (defwhopper (lock-internal xlib::clx-lock) (lock-argument) (catch 'timeout (continue-whopper lock-argument))) (defmethod (lock-block-internal xlib::clx-lock) (lock-argument) (declare (dbg:locking-function describe-process-lock-for-debugger self)) (when (null waiter-queue) (setf waiter-queue (make-scheduler-queue :name name)) (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) (let ((process (lock-argument-process lock-argument))) (unwind-protect (progn (lock-map-over-conflicting-owners self lock-argument #'(lambda (other-lock-arg) (add-promotion process lock-argument (lock-argument-process other-lock-arg) other-lock-arg))) (unless (timer-pending-p timer) (when (and (safe-to-use-timers %real-current-process) (not dbg:*debugger-might-have-system-problems*)) (reset-timer-relative-timer-units timer *lock-timer-interval*))) (assert (store-conditional (locf latch) process nil)) (sys:with-aborts-enabled (lock-latch) (let ((timeout (lock-argument-getf lock-argument :timeout nil))) (cond ((null timeout) (promotion-block waiter-queue name #'lock-lockable self lock-argument)) ((and (plusp timeout) (using-resource (timer process-block-timers) ;; Yeah, we know about the internal representation ;; of timers here. (setf (car (timer-args timer)) %real-current-process) (with-scheduler-locked (reset-timer-relative timer timeout) (flet ((lock-lockable-or-timeout (timer lock lock-argument) (or (not (timer-pending-p timer)) (lock-lockable lock lock-argument)))) (let ((priority (process-process-priority *current-process*))) (if (ldb-test %%scheduler-priority-preemption-field priority) (promotion-block waiter-queue name #'lock-lockable-or-timeout timer self lock-argument) ;; Change to preemptive priority so that when ;; unlock-internal wakes us up so we can have the lock, ;; we will really wake up right away (with-process-priority (dpb 1 %%scheduler-priority-preemption-field priority) (promotion-block waiter-queue name #'lock-lockable-or-timeout timer self lock-argument))))) (lock-lockable self lock-argument))))) (t (throw 'timeout nil)))))) (unless (store-conditional (locf latch) nil process) (lock-latch-wait-internal self)) (remove-promotions process lock-argument)))) (compile-flavor-methods xlib::clx-lock) cmucl-21a/src/clx/gl.lisp000066400000000000000000003417451260377556400154470ustar00rootroot00000000000000#+cmu (ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :gl (:use :common-lisp :xlib) (:import-from :glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" "CONTEXT-DISPLAY" "CONTEXT-TAG" "CONTEXT-RBUF" "CONTEXT-INDEX" ) (:import-from :xlib "DATA" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "CARD32-GET" "SEQUENCE-GET" "WITH-DISPLAY" "DISPLAY-FORCE-OUTPUT" "INT8" "INT16" "INT32" "INTEGER" "CARD8" "CARD16" "CARD32" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" "ASET-INT8" "ASET-INT16" "ASET-INT32" "DECLARE-BUFFUN" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" ) (:export "GET-STRING" ;; Rendering commands (alphabetical order) "ACCUM" "ACTIVE-TEXTURE-ARB" "ALPHA-FUNC" "BEGIN" "BIND-TEXTURE" "BLEND-COLOR" "BLEND-EQUOTION" "BLEND-FUNC" "CALL-LIST" "CLEAR" "CLEAR-ACCUM" "CLEAR-COLOR" "CLEAR-DEPTH" "CLEAR-INDEX" "CLEAR-STENCIL" "CLIP-PLANE" "COLOR-3B" "COLOR-3D" "COLOR-3F" "COLOR-3I" "COLOR-3S" "COLOR-3UB" "COLOR-3UI" "COLOR-3US" "COLOR-4B" "COLOR-4D" "COLOR-4F" "COLOR-4I" "COLOR-4S" "COLOR-4UB" "COLOR-4UI" "COLOR-4US" "COLOR-MASK" "COLOR-MATERIAL" "CONVOLUTION-PARAMETER-F" "CONVOLUTION-PARAMETER-I" "COPY-COLOR-SUB-TABLE" "COPY-COLOR-TABLE" "COPY-CONVOLUTION-FILTER-ID" "COPY-CONVOLUTION-FILTER-2D" "COPY-PIXELS" "COPY-TEX-IMAGE-1D" "COPY-TEX-IMAGE-2D" "COPY-TEX-SUB-IMAGE-1D" "COPY-TEX-SUB-IMAGE-2D" "COPY-TEX-SUB-IMAGE-3D" "CULL-FACE" "DEPTH-FUNC" "DEPTH-MASK" "DEPTH-RANGE" "DRAW-BUFFER" "EDGE-FLAG-V" "END" "EVAL-COORD-1D" "EVAL-COORD-1F" "EVAL-COORD-2D" "EVAL-COORD-2F" "EVAL-MESH-1" "EVAL-MESH-2" "EVAL-POINT-1" "EVAL-POINT-2" "FOG-F" "FOG-I" "FRONT-FACE" "FRUSTUM" "HINT" "HISTOGRAM" "INDEX-MASK" "INDEX-D" "INDEX-F" "INDEX-I" "INDEX-S" "INDEX-UB" "INIT-NAMES" "LIGHT-MODEL-F" "LIGHT-MODEL-I" "LIGHT-F" "LIGHT-FV" "LIGHT-I" "LIGHT-IV" "LINE-STIPPLE" "LINE-WIDTH" "LIST-BASE" "LOAD-IDENTITY" "LOAD-NAME" "LOGIC-OP" "MAP-GRID-1D" "MAP-GRID-1F" "MAP-GRID-2D" "MAP-GRID-2F" "MATERIAL-F" "MATERIAL-FV" "MATERIAL-I" "MATERIAL-IV" "MATRIX-MODE" "MINMAX" "MULTI-TEX-COORD-1D-ARB" "MULTI-TEX-COORD-1F-ARB" "MULTI-TEX-COORD-1I-ARB" "MULTI-TEX-COORD-1S-ARB" "MULTI-TEX-COORD-2D-ARB" "MULTI-TEX-COORD-2F-ARB" "MULTI-TEX-COORD-2I-ARB" "MULTI-TEX-COORD-2S-ARB" "MULTI-TEX-COORD-3D-ARB" "MULTI-TEX-COORD-3F-ARB" "MULTI-TEX-COORD-3I-ARB" "MULTI-TEX-COORD-3S-ARB" "MULTI-TEX-COORD-4D-ARB" "MULTI-TEX-COORD-4F-ARB" "MULTI-TEX-COORD-4I-ARB" "MULTI-TEX-COORD-4S-ARB" "NORMAL-3B" "NORMAL-3D" "NORMAL-3F" "NORMAL-3I" "NORMAL-3S" "ORTHO" "PASS-THROUGH" "PIXEL-TRANSFER-F" "PIXEL-TRANSFER-I" "PIXEL-ZOOM" "POINT-SIZE" "POLYGON-MODE" "POLYGON-OFFSET" "POP-ATTRIB" "POP-MATRIX" "POP-NAME" "PUSH-ATTRIB" "PUSH-MATRIX" "PUSH-NAME" "RASTER-POS-2D" "RASTER-POS-2F" "RASTER-POS-2I" "RASTER-POS-2S" "RASTER-POS-3D" "RASTER-POS-3F" "RASTER-POS-3I" "RASTER-POS-3S" "RASTER-POS-4D" "RASTER-POS-4F" "RASTER-POS-4I" "RASTER-POS-4S" "READ-BUFFER" "RECT-D" "RECT-F" "RECT-I" "RECT-S" "RESET-HISTOGRAM" "RESET-MINMAX" "ROTATE-D" "ROTATE-F" "SCALE-D" "SCALE-F" "SCISSOR" "SHADE-MODEL" "STENCIL-FUNC" "STENCIL-MASK" "STENCIL-OP" "TEX-ENV-F" "TEX-ENV-I" "TEX-GEN-D" "TEX-GEN-F" "TEX-GEN-I" "TEX-PARAMETER-F" "TEX-PARAMETER-I" "TRANSLATE-D" "TRANSLATE-F" "VERTEX-2D" "VERTEX-2F" "VERTEX-2I" "VERTEX-2S" "VERTEX-3D" "VERTEX-3F" "VERTEX-3I" "VERTEX-3S" "VERTEX-4D" "VERTEX-4F" "VERTEX-4I" "VERTEX-4S" "VIEWPORT" ;; * Where did this come from? ;;"NO-FLOATS" ;; Non-rendering commands "NEW-LIST" "END-LIST" "GEN-LISTS" "ENABLE" "DISABLE" "FLUSH" "FINISH" ;; Constants ;; Boolean "+FALSE+" "+TRUE+" ;; Types "+BYTE+" "+UNSIGNED-BYTE+" "+SHORT+" "+UNSIGNED-SHORT+" "+INT+" "+UNSIGNED-INT+" "+FLOAT+" "+DOUBLE+" "+2-BYTES+" "+3-BYTES+" "+4-BYTES+" ;; Primitives "+POINTS+" "+LINES+" "+LINE-LOOP+" "+LINE-STRIP+" "+TRIANGLES+" "+TRIANGLE-STRIP+" "+triangle-fan+" "+QUADS+" "+QUAD-STRIP+" "+POLYGON+" ;; Arrays "+VERTEX-ARRAY+" "+NORMAL-ARRAY+" "+COLOR-ARRAY+" "+INDEX-ARRAY+" "+TEXTURE-COORD-ARRAY+" "+EDGE-FLAG-ARRAY+" "+VERTEX-ARRAY-SIZE+" "+VERTEX-ARRAY-TYPE+" "+VERTEX-ARRAY-STRIDE+" "+NORMAL-ARRAY-TYPE+" "+NORMAL-ARRAY-STRIDE+" "+COLOR-ARRAY-SIZE+" "+COLOR-ARRAY-TYPE+" "+COLOR-ARRAY-STRIDE+" "+INDEX-ARRAY-TYPE+" "+INDEX-ARRAY-STRIDE+" "+TEXTURE-COORD-ARRAY-SIZE+" "+TEXTURE-COORD-ARRAY-TYPE+" "+TEXTURE-COORD-ARRAY-STRIDE+" "+EDGE-FLAG-ARRAY-STRIDE+" "+VERTEX-ARRAY-POINTER+" "+NORMAL-ARRAY-POINTER+" "+COLOR-ARRAY-POINTER+" "+INDEX-ARRAY-POINTER+" "+TEXTURE-COORD-ARRAY-POINTER+" "+EDGE-FLAG-ARRAY-POINTER+" ;; Array formats "+V2F+" "+V3F+" "+C4UB-V2F+" "+C4UB-V3F+" "+C3F-V3F+" "+N3F-V3F+" "+C4F-N3F-V3F+" "+T2F-V3F+" "+T4F-V4F+" "+T2F-C4UB-V3F+" "+T2F-C3F-V3F+" "+T2F-N3F-V3F+" "+T2F-C4F-N3F-V3F+" "+T4F-C4F-N3F-V4F+" ;; Matrices "+MATRIX-MODE+" "+MODELVIEW+" "+PROJECTION+" "+TEXTURE+" ;; Points "+POINT-SMOOTH+" "+POINT-SIZE+" "+POINT-SIZE-GRANULARITY+" "+POINT-SIZE-RANGE+" ;; Lines "+LINE-SMOOTH+" "+LINE-STIPPLE+" "+LINE-STIPPLE-PATTERN+" "+LINE-STIPPLE-REPEAT+" "+LINE-WIDTH+" "+LINE-WIDTH-GRANULARITY+" "+LINE-WIDTH-RANGE+" ;; Polygons "+POINT+" "+LINE+" "+FILL+" "+CW+" "+CCW+" "+FRONT+" "+BACK+" "+POLYGON-MODE+" "+POLYGON-SMOOTH+" "+POLYGON-STIPPLE+" "+EDGE-FLAG+" "+CULL-FACE+" "+CULL-FACE-MODE+" "+FRONT-FACE+" "+POLYGON-OFFSET-FACTOR+" "+POLYGON-OFFSET-UNITS+" "+POLYGON-OFFSET-POINT+" "+POLYGON-OFFSET-LINE+" "+POLYGON-OFFSET-FILL+" ;; Display Lists "+COMPILE+" "+COMPILE-AND-EXECUTE+" "+LIST-BASE+" "+LIST-INDEX+" "+LIST-MODE+" ;; Depth Buffer "+NEVER+" "+LESS+" "+EQUAL+" "+LEQUAL+" "+GREATER+" "+NOTEQUAL+" "+GEQUAL+" "+ALWAYS+" "+DEPTH-TEST+" "+DEPTH-BITS+" "+DEPTH-CLEAR-VALUE+" "+DEPTH-FUNC+" "+DEPTH-RANGE+" "+DEPTH-WRITEMASK+" "+DEPTH-COMPONENT+" ;; Lighting "+LIGHTING+" "+LIGHT0+" "+LIGHT1+" "+LIGHT2+" "+LIGHT3+" "+LIGHT4+" "+LIGHT5+" "+LIGHT6+" "+LIGHT7+" "+SPOT-EXPONENT+" "+SPOT-CUTOFF+" "+CONSTANT-ATTENUATION+" "+LINEAR-ATTENUATION+" "+QUADRATIC-ATTENUATION+" "+AMBIENT+" "+DIFFUSE+" "+SPECULAR+" "+SHININESS+" "+EMISSION+" "+POSITION+" "+SPOT-DIRECTION+" "+AMBIENT-AND-DIFFUSE+" "+COLOR-INDEXES+" "+LIGHT-MODEL-TWO-SIDE+" "+LIGHT-MODEL-LOCAL-VIEWER+" "+LIGHT-MODEL-AMBIENT+" "+FRONT-AND-BACK+" "+SHADE-MODEL+" "+FLAT+" "+SMOOTH+" "+COLOR-MATERIAL+" "+COLOR-MATERIAL-FACE+" "+COLOR-MATERIAL-PARAMETER+" "+NORMALIZE+" ;; Clipping planes "+CLIP-PLANE0+" "+CLIP-PLANE1+" "+CLIP-PLANE2+" "+CLIP-PLANE3+" "+CLIP-PLANE4+" "+CLIP-PLANE5+" ;; Accumulation buffer "+ACCUM-RED-BITS+" "+ACCUM-GREEN-BITS+" "+ACCUM-BLUE-BITS+" "+ACCUM-ALPHA-BITS+" "+ACCUM-CLEAR-VALUE+" "+ACCUM+" "+ADD+" "+LOAD+" "+MULT+" "+RETURN+" ;; Alpha Testing "+ALPHA-TEST+" "+ALPHA-TEST-REF+" "+ALPHA-TEST-FUNC+" ;; Blending "+BLEND+" "+BLEND-SRC+" "+BLEND-DST+" "+ZERO+" "+ONE+" "+SRC-COLOR+" "+ONE-MINUS-SRC-COLOR+" "+DST-COLOR+" "+ONE-MINUS-DST-COLOR+" "+SRC-ALPHA+" "+ONE-MINUS-SRC-ALPHA+" "+DST-ALPHA+" "+ONE-MINUS-DST-ALPHA+" "+SRC-ALPHA-SATURATE+" "+CONSTANT-COLOR+" "+ONE-MINUS-CONSTANT-COLOR+" "+CONSTANT-ALPHA+" "+ONE-MINUS-CONSTANT-ALPHA+" ;; Render mode "+FEEDBACK+" "+RENDER+" "+SELECT+" ;; Feedback "+2D+" "+3D+" "+3D-COLOR+" "+3D-COLOR-TEXTURE+" "+4D-COLOR-TEXTURE+" "+POINT-TOKEN+" "+LINE-TOKEN+" "+LINE-RESET-TOKEN+" "+POLYGON-TOKEN+" "+BITMAP-TOKEN+" "+DRAW-PIXEL-TOKEN+" "+COPY-PIXEL-TOKEN+" "+PASS-THROUGH-TOKEN+" "+FEEDBACK-BUFFER-POINTER+" "+FEEDBACK-BUFFER-SIZE+" "+FEEDBACK-BUFFER-TYPE+" ;; Selection "+SELECTION-BUFFER-POINTER+" "+SELECTION-BUFFER-SIZE+" ;; Fog "+FOG+" "+FOG-MODE+" "+FOG-DENSITY+" "+FOG-COLOR+" "+FOG-INDEX+" "+FOG-START+" "+FOG-END+" "+LINEAR+" "+EXP+" "+EXP2+" ;; Logic operations "+LOGIC-OP+" "+INDEX-LOGIC-OP+" "+COLOR-LOGIC-OP+" "+LOGIC-OP-MODE+" "+CLEAR+" "+SET+" "+COPY+" "+COPY-INVERTED+" "+NOOP+" "+INVERT+" "+AND+" "+NAND+" "+OR+" "+NOR+" "+XOR+" "+EQUIV+" "+AND-REVERSE+" "+AND-INVERTED+" "+OR-REVERSE+" "+OR-INVERTED+" ;; Stencil "+STENCIL-TEST+" "+STENCIL-WRITEMASK+" "+STENCIL-BITS+" "+STENCIL-FUNC+" "+STENCIL-VALUE-MASK+" "+STENCIL-REF+" "+STENCIL-FAIL+" "+STENCIL-PASS-DEPTH-PASS+" "+STENCIL-PASS-DEPTH-FAIL+" "+STENCIL-CLEAR-VALUE+" "+STENCIL-INDEX+" "+KEEP+" "+REPLACE+" "+INCR+" "+DECR+" ;; Buffers, Pixel Drawing/Reading "+NONE+" "+LEFT+" "+RIGHT+" "+FRONT-LEFT+" "+FRONT-RIGHT+" "+BACK-LEFT+" "+BACK-RIGHT+" "+AUX0+" "+AUX1+" "+AUX2+" "+AUX3+" "+COLOR-INDEX+" "+RED+" "+GREEN+" "+BLUE+" "+ALPHA+" "+LUMINANCE+" "+LUMINANCE-ALPHA+" "+ALPHA-BITS+" "+RED-BITS+" "+GREEN-BITS+" "+BLUE-BITS+" "+INDEX-BITS+" "+SUBPIXEL-BITS+" "+AUX-BUFFERS+" "+READ-BUFFER+" "+DRAW-BUFFER+" "+DOUBLEBUFFER+" "+STEREO+" "+BITMAP+" "+COLOR+" "+DEPTH+" "+STENCIL+" "+DITHER+" "+RGB+" "+RGBA+" ;; Implementation Limits "+MAX-LIST-NESTING+" "+MAX-ATTRIB-STACK-DEPTH+" "+MAX-MODELVIEW-STACK-DEPTH+" "+MAX-NAME-STACK-DEPTH+" "+MAX-PROJECTION-STACK-DEPTH+" "+MAX-TEXTURE-STACK-DEPTH+" "+MAX-EVAL-ORDER+" "+MAX-LIGHTS+" "+MAX-CLIP-PLANES+" "+MAX-TEXTURE-SIZE+" "+MAX-PIXEL-MAP-TABLE+" "+MAX-VIEWPORT-DIMS+" "+MAX-CLIENT-ATTRIB-STACK-DEPTH+" ;; Gets "+ATTRIB-STACK-DEPTH+" "+CLIENT-ATTRIB-STACK-DEPTH+" "+COLOR-CLEAR-VALUE+" "+COLOR-WRITEMASK+" "+CURRENT-INDEX+" "+CURRENT-COLOR+" "+CURRENT-NORMAL+" "+CURRENT-RASTER-COLOR+" "+CURRENT-RASTER-DISTANCE+" "+current-raster-index+" "+CURRENT-RASTER-POSITION+" "+CURRENT-RASTER-TEXTURE-COORDS+" "+CURRENT-RASTER-POSITION-VALID+" "+CURRENT-TEXTURE-COORDS+" "+INDEX-CLEAR-VALUE+" "+INDEX-MODE+" "+INDEX-WRITEMASK+" "+MODELVIEW-MATRIX+" "+MODELVIEW-STACK-DEPTH+" "+NAME-STACK-DEPTH+" "+PROJECTION-MATRIX+" "+PROJECTION-STACK-DEPTH+" "+RENDER-MODE+" "+RGBA-MODE+" "+TEXTURE-MATRIX+" "+TEXTURE-STACK-DEPTH+" "+VIEWPORT+" ;; GL Evaluators "+AUTO-NORMAL+" "+MAP1-COLOR-4+" "+MAP1-GRID-DOMAIN+" "+MAP1-GRID-SEGMENTS+" "+MAP1-INDEX+" "+MAP1-NORMAL+" "+MAP1-TEXTURE-COORD-1+" "+MAP1-TEXTURE-COORD-2+" "+MAP1-TEXTURE-COORD-3+" "+MAP1-TEXTURE-COORD-4+" "+MAP1-VERTEX-3+" "+MAP1-VERTEX-4+" "+MAP2-COLOR-4+" "+MAP2-GRID-DOMAIN+" "+MAP2-GRID-SEGMENTS+" "+MAP2-INDEX+" "+MAP2-NORMAL+" "+MAP2-TEXTURE-COORD-1+" "+MAP2-TEXTURE-COORD-2+" "+MAP2-TEXTURE-COORD-3+" "+MAP2-TEXTURE-COORD-4+" "+MAP2-VERTEX-3+" "+MAP2-VERTEX-4+" "+COEFF+" "+DOMAIN+" "+ORDER+" ;; Hints "+FOG-HINT+" "+LINE-SMOOTH-HINT+" "+PERSPECTIVE-CORRECTION-HINT+" "+POINT-SMOOTH-HINT+" "+POLYGON-SMOOTH-HINT+" "+DONT-CARE+" "+FASTEST+" "+NICEST+" ;; Scissor box "+SCISSOR-TEST+" "+SCISSOR-BOX+" ;; Pixel Mode / Transfer "+MAP-COLOR+" "+MAP-STENCIL+" "+INDEX-SHIFT+" "+INDEX-OFFSET+" "+RED-SCALE+" "+RED-BIAS+" "+GREEN-SCALE+" "+GREEN-BIAS+" "+BLUE-SCALE+" "+BLUE-BIAS+" "+ALPHA-SCALE+" "+ALPHA-BIAS+" "+DEPTH-SCALE+" "+DEPTH-BIAS+" "+PIXEL-MAP-S-TO-S-SIZE+" "+PIXEL-MAP-I-TO-I-SIZE+" "+PIXEL-MAP-I-TO-R-SIZE+" "+PIXEL-MAP-I-TO-G-SIZE+" "+PIXEL-MAP-I-TO-B-SIZE+" "+PIXEL-MAP-I-TO-A-SIZE+" "+PIXEL-MAP-R-TO-R-SIZE+" "+PIXEL-MAP-G-TO-G-SIZE+" "+PIXEL-MAP-B-TO-B-SIZE+" "+PIXEL-MAP-A-TO-A-SIZE+" "+PIXEL-MAP-S-TO-S+" "+PIXEL-MAP-I-TO-I+" "+PIXEL-MAP-I-TO-R+" "+PIXEL-MAP-I-TO-G+" "+PIXEL-MAP-I-TO-B+" "+PIXEL-MAP-I-TO-A+" "+PIXEL-MAP-R-TO-R+" "+PIXEL-MAP-G-TO-G+" "+PIXEL-MAP-B-TO-B+" "+PIXEL-MAP-A-TO-A+" "+PACK-ALIGNMENT+" "+PACK-LSB-FIRST+" "+PACK-ROW-LENGTH+" "+PACK-SKIP-PIXELS+" "+PACK-SKIP-ROWS+" "+PACK-SWAP-BYTES+" "+UNPACK-ALIGNMENT+" "+UNPACK-LSB-FIRST+" "+UNPACK-ROW-LENGTH+" "+UNPACK-SKIP-PIXELS+" "+UNPACK-SKIP-ROWS+" "+UNPACK-SWAP-BYTES+" "+ZOOM-X+" "+ZOOM-Y+" ;; Texture Mapping "+TEXTURE-ENV+" "+TEXTURE-ENV-MODE+" "+TEXTURE-1D+" "+TEXTURE-2D+" "+TEXTURE-WRAP-S+" "+TEXTURE-WRAP-T+" "+TEXTURE-MAG-FILTER+" "+TEXTURE-MIN-FILTER+" "+TEXTURE-ENV-COLOR+" "+TEXTURE-GEN-S+" "+TEXTURE-GEN-T+" "+TEXTURE-GEN-MODE+" "+TEXTURE-BORDER-COLOR+" "+TEXTURE-WIDTH+" "+TEXTURE-HEIGHT+" "+TEXTURE-BORDER+" "+TEXTURE-COMPONENTS+" "+TEXTURE-RED-SIZE+" "+TEXTURE-GREEN-SIZE+" "+TEXTURE-BLUE-SIZE+" "+TEXTURE-ALPHA-SIZE+" "+TEXTURE-LUMINANCE-SIZE+" "+TEXTURE-INTENSITY-SIZE+" "+NEAREST-MIPMAP-NEAREST+" "+NEAREST-MIPMAP-LINEAR+" "+LINEAR-MIPMAP-NEAREST+" "+LINEAR-MIPMAP-LINEAR+" "+OBJECT-LINEAR+" "+OBJECT-PLANE+" "+EYE-LINEAR+" "+EYE-PLANE+" "+SPHERE-MAP+" "+DECAL+" "+MODULATE+" "+NEAREST+" "+REPEAT+" "+CLAMP+" "+S+" "+T+" "+R+" "+Q+" "+TEXTURE-GEN-R+" "+TEXTURE-GEN-Q+" ;; GL 1.1 Texturing "+PROXY-TEXTURE-1D+" "+PROXY-TEXTURE-2D+" "+TEXTURE-PRIORITY+" "+TEXTURE-RESIDENT+" "+TEXTURE-BINDING-1D+" "+TEXTURE-BINDING-2D+" "+TEXTURE-INTERNAL-FORMAT+" "+PACK-SKIP-IMAGES+" "+PACK-IMAGE-HEIGHT+" "+UNPACK-SKIP-IMAGES+" "+UNPACK-IMAGE-HEIGHT+" "+TEXTURE-3D+" "+PROXY-TEXTURE-3D+" "+TEXTURE-DEPTH+" "+TEXTURE-WRAP-R+" "+MAX-3D-TEXTURE-SIZE+" "+TEXTURE-BINDING-3D+" ;; Internal texture formats (GL 1.1) "+ALPHA4+" "+ALPHA8+" "+ALPHA12+" "+ALPHA16+" "+LUMINANCE4+" "+LUMINANCE8+" "+LUMINANCE12+" "+LUMINANCE16+" "+LUMINANCE4-ALPHA4+" "+LUMINANCE6-ALPHA2+" "+LUMINANCE8-ALPHA8+" "+LUMINANCE12-ALPHA4+" "+LUMINANCE12-ALPHA12+" "+LUMINANCE16-ALPHA16+" "+INTENSITY+" "+INTENSITY4+" "+INTENSITY8+" "+INTENSITY12+" "+INTENSITY16+" "+R3-G3-B2+" "+RGB4+" "+RGB5+" "+RGB8+" "+RGB10+" "+RGB12+" "+RGB16+" "+RGBA2+" "+RGBA4+" "+RGB5-A1+" "+RGBA8+" "+rgb10-a2+" "+RGBA12+" "+RGBA16+" ;; Utility "+VENDOR+" "+RENDERER+" "+VERSION+" "+EXTENSIONS+" ;; Errors "+NO-ERROR+" "+INVALID-VALUE+" "+INVALID-ENUM+" "+INVALID-OPERATION+" "+STACK-OVERFLOW+" "+STACK-UNDERFLOW+" "+OUT-OF-MEMORY+" ;; OpenGL 1.2 "+RESCALE-NORMAL+" "+CLAMP-TO-EDGE+" "+MAX-ELEMENTS-VERTICES+" "+MAX-ELEMENTS-INDICES+" "+BGR+" "+BGRA+" "+UNSIGNED-BYTE-3-3-2+" "+UNSIGNED-BYTE-2-3-3-REV+" "+UNSIGNED-SHORT-5-6-5+" "+UNSIGNED-SHORT-5-6-5-REV+" "+UNSIGNED-SHORT-4-4-4-4+" "+UNSIGNED-SHORT-4-4-4-4-REV+" "+UNSIGNED-SHORT-5-5-5-1+" "+UNSIGNED-SHORT-1-5-5-5-REV+" "+UNSIGNED-INT-8-8-8-8+" "+UNSIGNED-INT-8-8-8-8-REV+" "+UNSIGNED-INT-10-10-10-2+" "+UNSIGNED-INT-2-10-10-10-REV+" "+LIGHT-MODEL-COLOR-CONTROL+" "+SINGLE-COLOR+" "+SEPARATE-SPECULAR-COLOR+" "+TEXTURE-MIN-LOD+" "+TEXTURE-MAX-LOD+" "+TEXTURE-BASE-LEVEL+" "+TEXTURE-MAX-LEVEL+" "+SMOOTH-POINT-SIZE-RANGE+" "+SMOOTH-POINT-SIZE-GRANULARITY+" "+SMOOTH-LINE-WIDTH-RANGE+" "+SMOOTH-LINE-WIDTH-GRANULARITY+" "+ALIASED-POINT-SIZE-RANGE+" "+ALIASED-LINE-WIDTH-RANGE+" ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table "+COLOR-TABLE+" "+POST-CONVOLUTION-COLOR-TABLE+" "+POST-COLOR-MATRIX-COLOR-TABLE+" "+PROXY-COLOR-TABLE+" "+PROXY-POST-CONVOLUTION-COLOR-TABLE+" "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+" "+COLOR-TABLE-SCALE+" "+COLOR-TABLE-BIAS+" "+COLOR-TABLE-FORMAT+" "+COLOR-TABLE-WIDTH+" "+COLOR-TABLE-RED-SIZE+" "+COLOR-TABLE-GREEN-SIZE+" "+COLOR-TABLE-BLUE-SIZE+" "+COLOR-TABLE-ALPHA-SIZE+" "+COLOR-TABLE-LUMINANCE-SIZE+" "+COLOR-TABLE-INTENSITY-SIZE+" ;; GL_EXT_convolution and GL_HP_convolution "+CONVOLUTION-1D+" "+CONVOLUTION-2D+" "+SEPARABLE-2D+" "+CONVOLUTION-BORDER-MODE+" "+CONVOLUTION-FILTER-SCALE+" "+CONVOLUTION-FILTER-BIAS+" "+REDUCE+" "+CONVOLUTION-FORMAT+" "+CONVOLUTION-WIDTH+" "+CONVOLUTION-HEIGHT+" "+MAX-CONVOLUTION-WIDTH+" "+MAX-CONVOLUTION-HEIGHT+" "+POST-CONVOLUTION-RED-SCALE+" "+POST-CONVOLUTION-GREEN-SCALE+" "+POST-CONVOLUTION-BLUE-SCALE+" "+POST-CONVOLUTION-ALPHA-SCALE+" "+POST-CONVOLUTION-RED-BIAS+" "+POST-CONVOLUTION-GREEN-BIAS+" "+POST-CONVOLUTION-BLUE-BIAS+" "+POST-CONVOLUTION-ALPHA-BIAS+" "+CONSTANT-BORDER+" "+REPLICATE-BORDER+" "+CONVOLUTION-BORDER-COLOR+" ;; GL_SGI_color_matrix "+COLOR-MATRIX+" "+COLOR-MATRIX-STACK-DEPTH+" "+MAX-COLOR-MATRIX-STACK-DEPTH+" "+POST-COLOR-MATRIX-RED-SCALE+" "+POST-COLOR-MATRIX-GREEN-SCALE+" "+POST-COLOR-MATRIX-BLUE-SCALE+" "+POST-COLOR-MATRIX-ALPHA-SCALE+" "+POST-COLOR-MATRIX-RED-BIAS+" "+POST-COLOR-MATRIX-GREEN-BIAS+" "+POST-COLOR-MATRIX-BLUE-BIAS+" "+POST-COLOR-MATRIX-ALPHA-BIAS+" ;; GL_EXT_histogram "+HISTOGRAM+" "+PROXY-HISTOGRAM+" "+HISTOGRAM-WIDTH+" "+HISTOGRAM-FORMAT+" "+HISTOGRAM-RED-SIZE+" "+HISTOGRAM-GREEN-SIZE+" "+HISTOGRAM-BLUE-SIZE+" "+HISTOGRAM-ALPHA-SIZE+" "+HISTOGRAM-LUMINANCE-SIZE+" "+HISTOGRAM-SINK+" "+MINMAX+" "+MINMAX-FORMAT+" "+MINMAX-SINK+" "+TABLE-TOO-LARGE+" ;; GL_EXT_blend_color, GL_EXT_blend_minmax "+BLEND-EQUATION+" "+MIN+" "+MAX+" "+FUNC-ADD+" "+FUNC-SUBTRACT+" "+FUNC-REVERSE-SUBTRACT+" ;; glPush/PopAttrib bits "+CURRENT-BIT+" "+POINT-BIT+" "+LINE-BIT+" "+POLYGON-BIT+" "+POLYGON-STIPPLE-BIT+" "+PIXEL-MODE-BIT+" "+LIGHTING-BIT+" "+FOG-BIT+" "+DEPTH-BUFFER-BIT+" "+ACCUM-BUFFER-BIT+" "+STENCIL-BUFFER-BIT+" "+VIEWPORT-BIT+" "+TRANSFORM-BIT+" "+ENABLE-BIT+" "+COLOR-BUFFER-BIT+" "+HINT-BIT+" "+EVAL-BIT+" "+LIST-BIT+" "+TEXTURE-BIT+" "+SCISSOR-BIT+" "+ALL-ATTRIB-BITS+" "+CLIENT-PIXEL-STORE-BIT+" "+CLIENT-VERTEX-ARRAY-BIT+" "+CLIENT-ALL-ATTRIB-BITS+" ;; ARB Multitexturing extension "+ARB-MULTITEXTURE+" "+TEXTURE0-ARB+" "+TEXTURE1-ARB+" "+TEXTURE2-ARB+" "+TEXTURE3-ARB+" "+TEXTURE4-ARB+" "+TEXTURE5-ARB+" "+TEXTURE6-ARB+" "+TEXTURE7-ARB+" "+TEXTURE8-ARB+" "+TEXTURE9-ARB+" "+TEXTURE10-ARB+" "+TEXTURE11-ARB+" "+TEXTURE12-ARB+" "+TEXTURE13-ARB+" "+TEXTURE14-ARB+" "+TEXTURE15-ARB+" "+TEXTURE16-ARB+" "+TEXTURE17-ARB+" "+TEXTURE18-ARB+" "+TEXTURE19-ARB+" "+TEXTURE20-ARB+" "+TEXTURE21-ARB+" "+TEXTURE22-ARB+" "+TEXTURE23-ARB+" "+TEXTURE24-ARB+" "+TEXTURE25-ARB+" "+TEXTURE26-ARB+" "+TEXTURE27-ARB+" "+TEXTURE28-ARB+" "+TEXTURE29-ARB+" "+TEXTURE30-ARB+" "+TEXTURE31-ARB+" "+ACTIVE-TEXTURE-ARB+" "+CLIENT-ACTIVE-TEXTURE-ARB+" "+MAX-TEXTURE-UNITS-ARB+" ;;; Misc extensions "+EXT-ABGR+" "+ABGR-EXT+" "+EXT-BLEND-COLOR+" "+CONSTANT-COLOR-EXT+" "+ONE-MINUS-CONSTANT-COLOR-EXT+" "+CONSTANT-ALPHA-EXT+" "+ONE-MINUS-CONSTANT-ALPHA-EXT+" "+blend-color-ext+" "+EXT-POLYGON-OFFSET+" "+POLYGON-OFFSET-EXT+" "+POLYGON-OFFSET-FACTOR-EXT+" "+POLYGON-OFFSET-BIAS-EXT+" "+EXT-TEXTURE3D+" "+PACK-SKIP-IMAGES-EXT+" "+PACK-IMAGE-HEIGHT-EXT+" "+UNPACK-SKIP-IMAGES-EXT+" "+UNPACK-IMAGE-HEIGHT-EXT+" "+TEXTURE-3D-EXT+" "+PROXY-TEXTURE-3D-EXT+" "+TEXTURE-DEPTH-EXT+" "+TEXTURE-WRAP-R-EXT+" "+MAX-3D-TEXTURE-SIZE-EXT+" "+TEXTURE-3D-BINDING-EXT+" "+EXT-TEXTURE-OBJECT+" "+TEXTURE-PRIORITY-EXT+" "+TEXTURE-RESIDENT-EXT+" "+TEXTURE-1D-BINDING-EXT+" "+TEXTURE-2D-BINDING-EXT+" "+EXT-RESCALE-NORMAL+" "+RESCALE-NORMAL-EXT+" "+EXT-VERTEX-ARRAY+" "+VERTEX-ARRAY-EXT+" "+NORMAL-ARRAY-EXT+" "+COLOR-ARRAY-EXT+" "+INDEX-ARRAY-EXT+" "+TEXTURE-COORD-ARRAY-EXT+" "+EDGE-FLAG-ARRAY-EXT+" "+VERTEX-ARRAY-SIZE-EXT+" "+VERTEX-ARRAY-TYPE-EXT+" "+VERTEX-ARRAY-STRIDE-EXT+" "+VERTEX-ARRAY-COUNT-EXT+" "+NORMAL-ARRAY-TYPE-EXT+" "+NORMAL-ARRAY-STRIDE-EXT+" "+NORMAL-ARRAY-COUNT-EXT+" "+COLOR-ARRAY-SIZE-EXT+" "+COLOR-ARRAY-TYPE-EXT+" "+COLOR-ARRAY-STRIDE-EXT+" "+COLOR-ARRAY-COUNT-EXT+" "+INDEX-ARRAY-TYPE-EXT+" "+INDEX-ARRAY-STRIDE-EXT+" "+INDEX-ARRAY-COUNT-EXT+" "+TEXTURE-COORD-ARRAY-SIZE-EXT+" "+TEXTURE-COORD-ARRAY-TYPE-EXT+" "+TEXTURE-COORD-ARRAY-STRIDE-EXT+" "+TEXTURE-COORD-ARRAY-COUNT-EXT+" "+EDGE-FLAG-ARRAY-STRIDE-EXT+" "+EDGE-FLAG-ARRAY-COUNT-EXT+" "+VERTEX-ARRAY-POINTER-EXT+" "+NORMAL-ARRAY-POINTER-EXT+" "+COLOR-ARRAY-POINTER-EXT+" "+INDEX-ARRAY-POINTER-EXT+" "+TEXTURE-COORD-ARRAY-POINTER-EXT+" "+EDGE-FLAG-ARRAY-POINTER-EXT+" "+SGIS-TEXTURE-EDGE-CLAMP+" "+CLAMP-TO-EDGE-SGIS+" "+EXT-BLEND-MINMAX+" "+FUNC-ADD-EXT+" "+MIN-EXT+" "+MAX-EXT+" "+BLEND-EQUATION-EXT+" "+EXT-BLEND-SUBTRACT+" "+FUNC-SUBTRACT-EXT+" "+FUNC-REVERSE-SUBTRACT-EXT+" "+EXT-BLEND-LOGIC-OP+" "+EXT-POINT-PARAMETERS+" "+POINT-SIZE-MIN-EXT+" "+POINT-SIZE-MAX-EXT+" "+POINT-FADE-THRESHOLD-SIZE-EXT+" "+DISTANCE-ATTENUATION-EXT+" "+EXT-PALETTED-TEXTURE+" "+TABLE-TOO-LARGE-EXT+" "+COLOR-TABLE-FORMAT-EXT+" "+COLOR-TABLE-WIDTH-EXT+" "+COLOR-TABLE-RED-SIZE-EXT+" "+COLOR-TABLE-GREEN-SIZE-EXT+" "+COLOR-TABLE-BLUE-SIZE-EXT+" "+COLOR-TABLE-ALPHA-SIZE-EXT+" "+COLOR-TABLE-LUMINANCE-SIZE-EXT+" "+COLOR-TABLE-INTENSITY-SIZE-EXT+" "+TEXTURE-INDEX-SIZE-EXT+" "+COLOR-INDEX1-EXT+" "+COLOR-INDEX2-EXT+" "+COLOR-INDEX4-EXT+" "+COLOR-INDEX8-EXT+" "+COLOR-INDEX12-EXT+" "+COLOR-INDEX16-EXT+" "+EXT-CLIP-VOLUME-HINT+" "+CLIP-VOLUME-CLIPPING-HINT-EXT+" "+EXT-COMPILED-VERTEX-ARRAY+" "+ARRAY-ELEMENT-LOCK-FIRST-EXT+" "+ARRAY-ELEMENT-LOCK-COUNT-EXT+" "+HP-OCCLUSION-TEST+" "+OCCLUSION-TEST-HP+" "+OCCLUSION-TEST-RESULT-HP+" "+EXT-SHARED-TEXTURE-PALETTE+" "+SHARED-TEXTURE-PALETTE-EXT+" "+EXT-STENCIL-WRAP+" "+INCR-WRAP-EXT+" "+DECR-WRAP-EXT+" "+NV-TEXGEN-REFLECTION+" "+NORMAL-MAP-NV+" "+REFLECTION-MAP-NV+" "+EXT-TEXTURE-ENV-ADD+" "+MESA-WINDOW-POS+" "+MESA-RESIZE-BUFFERS+" )) (in-package :gl) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +get-string+ 129) (defconstant +new-list+ 101) (defconstant +end-list+ 102) (defconstant +gen-lists+ 104) (defconstant +finish+ 108) (defconstant +disable+ 138) (defconstant +enable+ 139) (defconstant +flush+ 142) ;;; Constants. ;;; Shamelessly taken from CL-SDL. ;; Boolean (defconstant +false+ #x0) (defconstant +true+ #x1) ;; Types (defconstant +byte+ #x1400) (defconstant +unsigned-byte+ #x1401) (defconstant +short+ #x1402) (defconstant +unsigned-short+ #x1403) (defconstant +int+ #x1404) (defconstant +unsigned-int+ #x1405) (defconstant +float+ #x1406) (defconstant +double+ #x140a) (defconstant +2-bytes+ #x1407) (defconstant +3-bytes+ #x1408) (defconstant +4-bytes+ #x1409) ;; Primitives (defconstant +points+ #x0000) (defconstant +lines+ #x0001) (defconstant +line-loop+ #x0002) (defconstant +line-strip+ #x0003) (defconstant +triangles+ #x0004) (defconstant +triangle-strip+ #x0005) (defconstant +triangle-fan+ #x0006) (defconstant +quads+ #x0007) (defconstant +quad-strip+ #x0008) (defconstant +polygon+ #x0009) ;; Arrays (defconstant +vertex-array+ #x8074) (defconstant +normal-array+ #x8075) (defconstant +color-array+ #x8076) (defconstant +index-array+ #x8077) (defconstant +texture-coord-array+ #x8078) (defconstant +edge-flag-array+ #x8079) (defconstant +vertex-array-size+ #x807a) (defconstant +vertex-array-type+ #x807b) (defconstant +vertex-array-stride+ #x807c) (defconstant +normal-array-type+ #x807e) (defconstant +normal-array-stride+ #x807f) (defconstant +color-array-size+ #x8081) (defconstant +color-array-type+ #x8082) (defconstant +color-array-stride+ #x8083) (defconstant +index-array-type+ #x8085) (defconstant +index-array-stride+ #x8086) (defconstant +texture-coord-array-size+ #x8088) (defconstant +texture-coord-array-type+ #x8089) (defconstant +texture-coord-array-stride+ #x808a) (defconstant +edge-flag-array-stride+ #x808c) (defconstant +vertex-array-pointer+ #x808e) (defconstant +normal-array-pointer+ #x808f) (defconstant +color-array-pointer+ #x8090) (defconstant +index-array-pointer+ #x8091) (defconstant +texture-coord-array-pointer+ #x8092) (defconstant +edge-flag-array-pointer+ #x8093) ;; Array formats (defconstant +v2f+ #x2a20) (defconstant +v3f+ #x2a21) (defconstant +c4ub-v2f+ #x2a22) (defconstant +c4ub-v3f+ #x2a23) (defconstant +c3f-v3f+ #x2a24) (defconstant +n3f-v3f+ #x2a25) (defconstant +c4f-n3f-v3f+ #x2a26) (defconstant +t2f-v3f+ #x2a27) (defconstant +t4f-v4f+ #x2a28) (defconstant +t2f-c4ub-v3f+ #x2a29) (defconstant +t2f-c3f-v3f+ #x2a2a) (defconstant +t2f-n3f-v3f+ #x2a2b) (defconstant +t2f-c4f-n3f-v3f+ #x2a2c) (defconstant +t4f-c4f-n3f-v4f+ #x2a2d) ;; Matrices (defconstant +matrix-mode+ #x0ba0) (defconstant +modelview+ #x1700) (defconstant +projection+ #x1701) (defconstant +texture+ #x1702) ;; Points (defconstant +point-smooth+ #x0b10) (defconstant +point-size+ #x0b11) (defconstant +point-size-granularity+ #x0b13) (defconstant +point-size-range+ #x0b12) ;; Lines (defconstant +line-smooth+ #x0b20) (defconstant +line-stipple+ #x0b24) (defconstant +line-stipple-pattern+ #x0b25) (defconstant +line-stipple-repeat+ #x0b26) (defconstant +line-width+ #x0b21) (defconstant +line-width-granularity+ #x0b23) (defconstant +line-width-range+ #x0b22) ;; Polygons (defconstant +point+ #x1b00) (defconstant +line+ #x1b01) (defconstant +fill+ #x1b02) (defconstant +cw+ #x0900) (defconstant +ccw+ #x0901) (defconstant +front+ #x0404) (defconstant +back+ #x0405) (defconstant +polygon-mode+ #x0b40) (defconstant +polygon-smooth+ #x0b41) (defconstant +polygon-stipple+ #x0b42) (defconstant +edge-flag+ #x0b43) (defconstant +cull-face+ #x0b44) (defconstant +cull-face-mode+ #x0b45) (defconstant +front-face+ #x0b46) (defconstant +polygon-offset-factor+ #x8038) (defconstant +polygon-offset-units+ #x2a00) (defconstant +polygon-offset-point+ #x2a01) (defconstant +polygon-offset-line+ #x2a02) (defconstant +polygon-offset-fill+ #x8037) ;; Display Lists (defconstant +compile+ #x1300) (defconstant +compile-and-execute+ #x1301) (defconstant +list-base+ #x0b32) (defconstant +list-index+ #x0b33) (defconstant +list-mode+ #x0b30) ;; Depth Buffer (defconstant +never+ #x0200) (defconstant +less+ #x0201) (defconstant +equal+ #x0202) (defconstant +lequal+ #x0203) (defconstant +greater+ #x0204) (defconstant +notequal+ #x0205) (defconstant +gequal+ #x0206) (defconstant +always+ #x0207) (defconstant +depth-test+ #x0b71) (defconstant +depth-bits+ #x0d56) (defconstant +depth-clear-value+ #x0b73) (defconstant +depth-func+ #x0b74) (defconstant +depth-range+ #x0b70) (defconstant +depth-writemask+ #x0b72) (defconstant +depth-component+ #x1902) ;; Lighting (defconstant +lighting+ #x0b50) (defconstant +light0+ #x4000) (defconstant +light1+ #x4001) (defconstant +light2+ #x4002) (defconstant +light3+ #x4003) (defconstant +light4+ #x4004) (defconstant +light5+ #x4005) (defconstant +light6+ #x4006) (defconstant +light7+ #x4007) (defconstant +spot-exponent+ #x1205) (defconstant +spot-cutoff+ #x1206) (defconstant +constant-attenuation+ #x1207) (defconstant +linear-attenuation+ #x1208) (defconstant +quadratic-attenuation+ #x1209) (defconstant +ambient+ #x1200) (defconstant +diffuse+ #x1201) (defconstant +specular+ #x1202) (defconstant +shininess+ #x1601) (defconstant +emission+ #x1600) (defconstant +position+ #x1203) (defconstant +spot-direction+ #x1204) (defconstant +ambient-and-diffuse+ #x1602) (defconstant +color-indexes+ #x1603) (defconstant +light-model-two-side+ #x0b52) (defconstant +light-model-local-viewer+ #x0b51) (defconstant +light-model-ambient+ #x0b53) (defconstant +front-and-back+ #x0408) (defconstant +shade-model+ #x0b54) (defconstant +flat+ #x1d00) (defconstant +smooth+ #x1d01) (defconstant +color-material+ #x0b57) (defconstant +color-material-face+ #x0b55) (defconstant +color-material-parameter+ #x0b56) (defconstant +normalize+ #x0ba1) ;; Clipping planes (defconstant +clip-plane0+ #x3000) (defconstant +clip-plane1+ #x3001) (defconstant +clip-plane2+ #x3002) (defconstant +clip-plane3+ #x3003) (defconstant +clip-plane4+ #x3004) (defconstant +clip-plane5+ #x3005) ;; Accumulation buffer (defconstant +accum-red-bits+ #x0d58) (defconstant +accum-green-bits+ #x0d59) (defconstant +accum-blue-bits+ #x0d5a) (defconstant +accum-alpha-bits+ #x0d5b) (defconstant +accum-clear-value+ #x0b80) (defconstant +accum+ #x0100) (defconstant +add+ #x0104) (defconstant +load+ #x0101) (defconstant +mult+ #x0103) (defconstant +return+ #x0102) ;; Alpha Testing (defconstant +alpha-test+ #x0bc0) (defconstant +alpha-test-ref+ #x0bc2) (defconstant +alpha-test-func+ #x0bc1) ;; Blending (defconstant +blend+ #x0be2) (defconstant +blend-src+ #x0be1) (defconstant +blend-dst+ #x0be0) (defconstant +zero+ #x0) (defconstant +one+ #x1) (defconstant +src-color+ #x0300) (defconstant +one-minus-src-color+ #x0301) (defconstant +dst-color+ #x0306) (defconstant +one-minus-dst-color+ #x0307) (defconstant +src-alpha+ #x0302) (defconstant +one-minus-src-alpha+ #x0303) (defconstant +dst-alpha+ #x0304) (defconstant +one-minus-dst-alpha+ #x0305) (defconstant +src-alpha-saturate+ #x0308) (defconstant +constant-color+ #x8001) (defconstant +one-minus-constant-color+ #x8002) (defconstant +constant-alpha+ #x8003) (defconstant +one-minus-constant-alpha+ #x8004) ;; Render mode (defconstant +feedback+ #x1c01) (defconstant +render+ #x1c00) (defconstant +select+ #x1c02) ;; Feedback (defconstant +2d+ #x0600) (defconstant +3d+ #x0601) (defconstant +3d-color+ #x0602) (defconstant +3d-color-texture+ #x0603) (defconstant +4d-color-texture+ #x0604) (defconstant +point-token+ #x0701) (defconstant +line-token+ #x0702) (defconstant +line-reset-token+ #x0707) (defconstant +polygon-token+ #x0703) (defconstant +bitmap-token+ #x0704) (defconstant +draw-pixel-token+ #x0705) (defconstant +copy-pixel-token+ #x0706) (defconstant +pass-through-token+ #x0700) (defconstant +feedback-buffer-pointer+ #x0df0) (defconstant +feedback-buffer-size+ #x0df1) (defconstant +feedback-buffer-type+ #x0df2) ;; Selection (defconstant +selection-buffer-pointer+ #x0df3) (defconstant +selection-buffer-size+ #x0df4) ;; Fog (defconstant +fog+ #x0b60) (defconstant +fog-mode+ #x0b65) (defconstant +fog-density+ #x0b62) (defconstant +fog-color+ #x0b66) (defconstant +fog-index+ #x0b61) (defconstant +fog-start+ #x0b63) (defconstant +fog-end+ #x0b64) (defconstant +linear+ #x2601) (defconstant +exp+ #x0800) (defconstant +exp2+ #x0801) ;; Logic operations (defconstant +logic-op+ #x0bf1) (defconstant +index-logic-op+ #x0bf1) (defconstant +color-logic-op+ #x0bf2) (defconstant +logic-op-mode+ #x0bf0) (defconstant +clear+ #x1500) (defconstant +set+ #x150f) (defconstant +copy+ #x1503) (defconstant +copy-inverted+ #x150c) (defconstant +noop+ #x1505) (defconstant +invert+ #x150a) (defconstant +and+ #x1501) (defconstant +nand+ #x150e) (defconstant +or+ #x1507) (defconstant +nor+ #x1508) (defconstant +xor+ #x1506) (defconstant +equiv+ #x1509) (defconstant +and-reverse+ #x1502) (defconstant +and-inverted+ #x1504) (defconstant +or-reverse+ #x150b) (defconstant +or-inverted+ #x150d) ;; Stencil (defconstant +stencil-test+ #x0b90) (defconstant +stencil-writemask+ #x0b98) (defconstant +stencil-bits+ #x0d57) (defconstant +stencil-func+ #x0b92) (defconstant +stencil-value-mask+ #x0b93) (defconstant +stencil-ref+ #x0b97) (defconstant +stencil-fail+ #x0b94) (defconstant +stencil-pass-depth-pass+ #x0b96) (defconstant +stencil-pass-depth-fail+ #x0b95) (defconstant +stencil-clear-value+ #x0b91) (defconstant +stencil-index+ #x1901) (defconstant +keep+ #x1e00) (defconstant +replace+ #x1e01) (defconstant +incr+ #x1e02) (defconstant +decr+ #x1e03) ;; Buffers, Pixel Drawing/Reading (defconstant +none+ #x0) (defconstant +left+ #x0406) (defconstant +right+ #x0407) (defconstant +front-left+ #x0400) (defconstant +front-right+ #x0401) (defconstant +back-left+ #x0402) (defconstant +back-right+ #x0403) (defconstant +aux0+ #x0409) (defconstant +aux1+ #x040a) (defconstant +aux2+ #x040b) (defconstant +aux3+ #x040c) (defconstant +color-index+ #x1900) (defconstant +red+ #x1903) (defconstant +green+ #x1904) (defconstant +blue+ #x1905) (defconstant +alpha+ #x1906) (defconstant +luminance+ #x1909) (defconstant +luminance-alpha+ #x190a) (defconstant +alpha-bits+ #x0d55) (defconstant +red-bits+ #x0d52) (defconstant +green-bits+ #x0d53) (defconstant +blue-bits+ #x0d54) (defconstant +index-bits+ #x0d51) (defconstant +subpixel-bits+ #x0d50) (defconstant +aux-buffers+ #x0c00) (defconstant +read-buffer+ #x0c02) (defconstant +draw-buffer+ #x0c01) (defconstant +doublebuffer+ #x0c32) (defconstant +stereo+ #x0c33) (defconstant +bitmap+ #x1a00) (defconstant +color+ #x1800) (defconstant +depth+ #x1801) (defconstant +stencil+ #x1802) (defconstant +dither+ #x0bd0) (defconstant +rgb+ #x1907) (defconstant +rgba+ #x1908) ;; Implementation Limits (defconstant +max-list-nesting+ #x0b31) (defconstant +max-attrib-stack-depth+ #x0d35) (defconstant +max-modelview-stack-depth+ #x0d36) (defconstant +max-name-stack-depth+ #x0d37) (defconstant +max-projection-stack-depth+ #x0d38) (defconstant +max-texture-stack-depth+ #x0d39) (defconstant +max-eval-order+ #x0d30) (defconstant +max-lights+ #x0d31) (defconstant +max-clip-planes+ #x0d32) (defconstant +max-texture-size+ #x0d33) (defconstant +max-pixel-map-table+ #x0d34) (defconstant +max-viewport-dims+ #x0d3a) (defconstant +max-client-attrib-stack-depth+ #x0d3b) ;; Gets (defconstant +attrib-stack-depth+ #x0bb0) (defconstant +client-attrib-stack-depth+ #x0bb1) (defconstant +color-clear-value+ #x0c22) (defconstant +color-writemask+ #x0c23) (defconstant +current-index+ #x0b01) (defconstant +current-color+ #x0b00) (defconstant +current-normal+ #x0b02) (defconstant +current-raster-color+ #x0b04) (defconstant +current-raster-distance+ #x0b09) (defconstant +current-raster-index+ #x0b05) (defconstant +current-raster-position+ #x0b07) (defconstant +current-raster-texture-coords+ #x0b06) (defconstant +current-raster-position-valid+ #x0b08) (defconstant +current-texture-coords+ #x0b03) (defconstant +index-clear-value+ #x0c20) (defconstant +index-mode+ #x0c30) (defconstant +index-writemask+ #x0c21) (defconstant +modelview-matrix+ #x0ba6) (defconstant +modelview-stack-depth+ #x0ba3) (defconstant +name-stack-depth+ #x0d70) (defconstant +projection-matrix+ #x0ba7) (defconstant +projection-stack-depth+ #x0ba4) (defconstant +render-mode+ #x0c40) (defconstant +rgba-mode+ #x0c31) (defconstant +texture-matrix+ #x0ba8) (defconstant +texture-stack-depth+ #x0ba5) (defconstant +viewport+ #x0ba2) ;; GL Evaluators (defconstant +auto-normal+ #x0d80) (defconstant +map1-color-4+ #x0d90) (defconstant +map1-grid-domain+ #x0dd0) (defconstant +map1-grid-segments+ #x0dd1) (defconstant +map1-index+ #x0d91) (defconstant +map1-normal+ #x0d92) (defconstant +map1-texture-coord-1+ #x0d93) (defconstant +map1-texture-coord-2+ #x0d94) (defconstant +map1-texture-coord-3+ #x0d95) (defconstant +map1-texture-coord-4+ #x0d96) (defconstant +map1-vertex-3+ #x0d97) (defconstant +map1-vertex-4+ #x0d98) (defconstant +map2-color-4+ #x0db0) (defconstant +map2-grid-domain+ #x0dd2) (defconstant +map2-grid-segments+ #x0dd3) (defconstant +map2-index+ #x0db1) (defconstant +map2-normal+ #x0db2) (defconstant +map2-texture-coord-1+ #x0db3) (defconstant +map2-texture-coord-2+ #x0db4) (defconstant +map2-texture-coord-3+ #x0db5) (defconstant +map2-texture-coord-4+ #x0db6) (defconstant +map2-vertex-3+ #x0db7) (defconstant +map2-vertex-4+ #x0db8) (defconstant +coeff+ #x0a00) (defconstant +domain+ #x0a02) (defconstant +order+ #x0a01) ;; Hints (defconstant +fog-hint+ #x0c54) (defconstant +line-smooth-hint+ #x0c52) (defconstant +perspective-correction-hint+ #x0c50) (defconstant +point-smooth-hint+ #x0c51) (defconstant +polygon-smooth-hint+ #x0c53) (defconstant +dont-care+ #x1100) (defconstant +fastest+ #x1101) (defconstant +nicest+ #x1102) ;; Scissor box (defconstant +scissor-test+ #x0c11) (defconstant +scissor-box+ #x0c10) ;; Pixel Mode / Transfer (defconstant +map-color+ #x0d10) (defconstant +map-stencil+ #x0d11) (defconstant +index-shift+ #x0d12) (defconstant +index-offset+ #x0d13) (defconstant +red-scale+ #x0d14) (defconstant +red-bias+ #x0d15) (defconstant +green-scale+ #x0d18) (defconstant +green-bias+ #x0d19) (defconstant +blue-scale+ #x0d1a) (defconstant +blue-bias+ #x0d1b) (defconstant +alpha-scale+ #x0d1c) (defconstant +alpha-bias+ #x0d1d) (defconstant +depth-scale+ #x0d1e) (defconstant +depth-bias+ #x0d1f) (defconstant +pixel-map-s-to-s-size+ #x0cb1) (defconstant +pixel-map-i-to-i-size+ #x0cb0) (defconstant +pixel-map-i-to-r-size+ #x0cb2) (defconstant +pixel-map-i-to-g-size+ #x0cb3) (defconstant +pixel-map-i-to-b-size+ #x0cb4) (defconstant +pixel-map-i-to-a-size+ #x0cb5) (defconstant +pixel-map-r-to-r-size+ #x0cb6) (defconstant +pixel-map-g-to-g-size+ #x0cb7) (defconstant +pixel-map-b-to-b-size+ #x0cb8) (defconstant +pixel-map-a-to-a-size+ #x0cb9) (defconstant +pixel-map-s-to-s+ #x0c71) (defconstant +pixel-map-i-to-i+ #x0c70) (defconstant +pixel-map-i-to-r+ #x0c72) (defconstant +pixel-map-i-to-g+ #x0c73) (defconstant +pixel-map-i-to-b+ #x0c74) (defconstant +pixel-map-i-to-a+ #x0c75) (defconstant +pixel-map-r-to-r+ #x0c76) (defconstant +pixel-map-g-to-g+ #x0c77) (defconstant +pixel-map-b-to-b+ #x0c78) (defconstant +pixel-map-a-to-a+ #x0c79) (defconstant +pack-alignment+ #x0d05) (defconstant +pack-lsb-first+ #x0d01) (defconstant +pack-row-length+ #x0d02) (defconstant +pack-skip-pixels+ #x0d04) (defconstant +pack-skip-rows+ #x0d03) (defconstant +pack-swap-bytes+ #x0d00) (defconstant +unpack-alignment+ #x0cf5) (defconstant +unpack-lsb-first+ #x0cf1) (defconstant +unpack-row-length+ #x0cf2) (defconstant +unpack-skip-pixels+ #x0cf4) (defconstant +unpack-skip-rows+ #x0cf3) (defconstant +unpack-swap-bytes+ #x0cf0) (defconstant +zoom-x+ #x0d16) (defconstant +zoom-y+ #x0d17) ;; Texture Mapping (defconstant +texture-env+ #x2300) (defconstant +texture-env-mode+ #x2200) (defconstant +texture-1d+ #x0de0) (defconstant +texture-2d+ #x0de1) (defconstant +texture-wrap-s+ #x2802) (defconstant +texture-wrap-t+ #x2803) (defconstant +texture-mag-filter+ #x2800) (defconstant +texture-min-filter+ #x2801) (defconstant +texture-env-color+ #x2201) (defconstant +texture-gen-s+ #x0c60) (defconstant +texture-gen-t+ #x0c61) (defconstant +texture-gen-mode+ #x2500) (defconstant +texture-border-color+ #x1004) (defconstant +texture-width+ #x1000) (defconstant +texture-height+ #x1001) (defconstant +texture-border+ #x1005) (defconstant +texture-components+ #x1003) (defconstant +texture-red-size+ #x805c) (defconstant +texture-green-size+ #x805d) (defconstant +texture-blue-size+ #x805e) (defconstant +texture-alpha-size+ #x805f) (defconstant +texture-luminance-size+ #x8060) (defconstant +texture-intensity-size+ #x8061) (defconstant +nearest-mipmap-nearest+ #x2700) (defconstant +nearest-mipmap-linear+ #x2702) (defconstant +linear-mipmap-nearest+ #x2701) (defconstant +linear-mipmap-linear+ #x2703) (defconstant +object-linear+ #x2401) (defconstant +object-plane+ #x2501) (defconstant +eye-linear+ #x2400) (defconstant +eye-plane+ #x2502) (defconstant +sphere-map+ #x2402) (defconstant +decal+ #x2101) (defconstant +modulate+ #x2100) (defconstant +nearest+ #x2600) (defconstant +repeat+ #x2901) (defconstant +clamp+ #x2900) (defconstant +s+ #x2000) (defconstant +t+ #x2001) (defconstant +r+ #x2002) (defconstant +q+ #x2003) (defconstant +texture-gen-r+ #x0c62) (defconstant +texture-gen-q+ #x0c63) ;; GL 1.1 Texturing (defconstant +proxy-texture-1d+ #x8063) (defconstant +proxy-texture-2d+ #x8064) (defconstant +texture-priority+ #x8066) (defconstant +texture-resident+ #x8067) (defconstant +texture-binding-1d+ #x8068) (defconstant +texture-binding-2d+ #x8069) (defconstant +texture-internal-format+ #x1003) (defconstant +pack-skip-images+ #x806b) (defconstant +pack-image-height+ #x806c) (defconstant +unpack-skip-images+ #x806d) (defconstant +unpack-image-height+ #x806e) (defconstant +texture-3d+ #x806f) (defconstant +proxy-texture-3d+ #x8070) (defconstant +texture-depth+ #x8071) (defconstant +texture-wrap-r+ #x8072) (defconstant +max-3d-texture-size+ #x8073) (defconstant +texture-binding-3d+ #x806a) ;; Internal texture formats (GL 1.1) (defconstant +alpha4+ #x803b) (defconstant +alpha8+ #x803c) (defconstant +alpha12+ #x803d) (defconstant +alpha16+ #x803e) (defconstant +luminance4+ #x803f) (defconstant +luminance8+ #x8040) (defconstant +luminance12+ #x8041) (defconstant +luminance16+ #x8042) (defconstant +luminance4-alpha4+ #x8043) (defconstant +luminance6-alpha2+ #x8044) (defconstant +luminance8-alpha8+ #x8045) (defconstant +luminance12-alpha4+ #x8046) (defconstant +luminance12-alpha12+ #x8047) (defconstant +luminance16-alpha16+ #x8048) (defconstant +intensity+ #x8049) (defconstant +intensity4+ #x804a) (defconstant +intensity8+ #x804b) (defconstant +intensity12+ #x804c) (defconstant +intensity16+ #x804d) (defconstant +r3-g3-b2+ #x2a10) (defconstant +rgb4+ #x804f) (defconstant +rgb5+ #x8050) (defconstant +rgb8+ #x8051) (defconstant +rgb10+ #x8052) (defconstant +rgb12+ #x8053) (defconstant +rgb16+ #x8054) (defconstant +rgba2+ #x8055) (defconstant +rgba4+ #x8056) (defconstant +rgb5-a1+ #x8057) (defconstant +rgba8+ #x8058) (defconstant +rgb10-a2+ #x8059) (defconstant +rgba12+ #x805a) (defconstant +rgba16+ #x805b) ;; Utility (defconstant +vendor+ #x1f00) (defconstant +renderer+ #x1f01) (defconstant +version+ #x1f02) (defconstant +extensions+ #x1f03) ;; Errors (defconstant +no-error+ #x0) (defconstant +invalid-value+ #x0501) (defconstant +invalid-enum+ #x0500) (defconstant +invalid-operation+ #x0502) (defconstant +stack-overflow+ #x0503) (defconstant +stack-underflow+ #x0504) (defconstant +out-of-memory+ #x0505) ;; OpenGL 1.2 (defconstant +rescale-normal+ #x803a) (defconstant +clamp-to-edge+ #x812f) (defconstant +max-elements-vertices+ #x80e8) (defconstant +max-elements-indices+ #x80e9) (defconstant +bgr+ #x80e0) (defconstant +bgra+ #x80e1) (defconstant +unsigned-byte-3-3-2+ #x8032) (defconstant +unsigned-byte-2-3-3-rev+ #x8362) (defconstant +unsigned-short-5-6-5+ #x8363) (defconstant +unsigned-short-5-6-5-rev+ #x8364) (defconstant +unsigned-short-4-4-4-4+ #x8033) (defconstant +unsigned-short-4-4-4-4-rev+ #x8365) (defconstant +unsigned-short-5-5-5-1+ #x8034) (defconstant +unsigned-short-1-5-5-5-rev+ #x8366) (defconstant +unsigned-int-8-8-8-8+ #x8035) (defconstant +unsigned-int-8-8-8-8-rev+ #x8367) (defconstant +unsigned-int-10-10-10-2+ #x8036) (defconstant +unsigned-int-2-10-10-10-rev+ #x8368) (defconstant +light-model-color-control+ #x81f8) (defconstant +single-color+ #x81f9) (defconstant +separate-specular-color+ #x81fa) (defconstant +texture-min-lod+ #x813a) (defconstant +texture-max-lod+ #x813b) (defconstant +texture-base-level+ #x813c) (defconstant +texture-max-level+ #x813d) (defconstant +smooth-point-size-range+ #x0b12) (defconstant +smooth-point-size-granularity+ #x0b13) (defconstant +smooth-line-width-range+ #x0b22) (defconstant +smooth-line-width-granularity+ #x0b23) (defconstant +aliased-point-size-range+ #x846d) (defconstant +aliased-line-width-range+ #x846e) ;; OpenGL 1.2 Imaging subset ;; GL_EXT_color_table (defconstant +color-table+ #x80d0) (defconstant +post-convolution-color-table+ #x80d1) (defconstant +post-color-matrix-color-table+ #x80d2) (defconstant +proxy-color-table+ #x80d3) (defconstant +proxy-post-convolution-color-table+ #x80d4) (defconstant +proxy-post-color-matrix-color-table+ #x80d5) (defconstant +color-table-scale+ #x80d6) (defconstant +color-table-bias+ #x80d7) (defconstant +color-table-format+ #x80d8) (defconstant +color-table-width+ #x80d9) (defconstant +color-table-red-size+ #x80da) (defconstant +color-table-green-size+ #x80db) (defconstant +color-table-blue-size+ #x80dc) (defconstant +color-table-alpha-size+ #x80dd) (defconstant +color-table-luminance-size+ #x80de) (defconstant +color-table-intensity-size+ #x80df) ;; GL_EXT_convolution and GL_HP_convolution (defconstant +convolution-1d+ #x8010) (defconstant +convolution-2d+ #x8011) (defconstant +separable-2d+ #x8012) (defconstant +convolution-border-mode+ #x8013) (defconstant +convolution-filter-scale+ #x8014) (defconstant +convolution-filter-bias+ #x8015) (defconstant +reduce+ #x8016) (defconstant +convolution-format+ #x8017) (defconstant +convolution-width+ #x8018) (defconstant +convolution-height+ #x8019) (defconstant +max-convolution-width+ #x801a) (defconstant +max-convolution-height+ #x801b) (defconstant +post-convolution-red-scale+ #x801c) (defconstant +post-convolution-green-scale+ #x801d) (defconstant +post-convolution-blue-scale+ #x801e) (defconstant +post-convolution-alpha-scale+ #x801f) (defconstant +post-convolution-red-bias+ #x8020) (defconstant +post-convolution-green-bias+ #x8021) (defconstant +post-convolution-blue-bias+ #x8022) (defconstant +post-convolution-alpha-bias+ #x8023) (defconstant +constant-border+ #x8151) (defconstant +replicate-border+ #x8153) (defconstant +convolution-border-color+ #x8154) ;; GL_SGI_color_matrix (defconstant +color-matrix+ #x80b1) (defconstant +color-matrix-stack-depth+ #x80b2) (defconstant +max-color-matrix-stack-depth+ #x80b3) (defconstant +post-color-matrix-red-scale+ #x80b4) (defconstant +post-color-matrix-green-scale+ #x80b5) (defconstant +post-color-matrix-blue-scale+ #x80b6) (defconstant +post-color-matrix-alpha-scale+ #x80b7) (defconstant +post-color-matrix-red-bias+ #x80b8) (defconstant +post-color-matrix-green-bias+ #x80b9) (defconstant +post-color-matrix-blue-bias+ #x80ba) (defconstant +post-color-matrix-alpha-bias+ #x80bb) ;; GL_EXT_histogram (defconstant +histogram+ #x8024) (defconstant +proxy-histogram+ #x8025) (defconstant +histogram-width+ #x8026) (defconstant +histogram-format+ #x8027) (defconstant +histogram-red-size+ #x8028) (defconstant +histogram-green-size+ #x8029) (defconstant +histogram-blue-size+ #x802a) (defconstant +histogram-alpha-size+ #x802b) (defconstant +histogram-luminance-size+ #x802c) (defconstant +histogram-sink+ #x802d) (defconstant +minmax+ #x802e) (defconstant +minmax-format+ #x802f) (defconstant +minmax-sink+ #x8030) (defconstant +table-too-large+ #x8031) ;; GL_EXT_blend_color, GL_EXT_blend_minmax (defconstant +blend-equation+ #x8009) (defconstant +min+ #x8007) (defconstant +max+ #x8008) (defconstant +func-add+ #x8006) (defconstant +func-subtract+ #x800a) (defconstant +func-reverse-subtract+ #x800b) ;; glPush/PopAttrib bits (defconstant +current-bit+ #x00000001) (defconstant +point-bit+ #x00000002) (defconstant +line-bit+ #x00000004) (defconstant +polygon-bit+ #x00000008) (defconstant +polygon-stipple-bit+ #x00000010) (defconstant +pixel-mode-bit+ #x00000020) (defconstant +lighting-bit+ #x00000040) (defconstant +fog-bit+ #x00000080) (defconstant +depth-buffer-bit+ #x00000100) (defconstant +accum-buffer-bit+ #x00000200) (defconstant +stencil-buffer-bit+ #x00000400) (defconstant +viewport-bit+ #x00000800) (defconstant +transform-bit+ #x00001000) (defconstant +enable-bit+ #x00002000) (defconstant +color-buffer-bit+ #x00004000) (defconstant +hint-bit+ #x00008000) (defconstant +eval-bit+ #x00010000) (defconstant +list-bit+ #x00020000) (defconstant +texture-bit+ #x00040000) (defconstant +scissor-bit+ #x00080000) (defconstant +all-attrib-bits+ #x000fffff) (defconstant +client-pixel-store-bit+ #x00000001) (defconstant +client-vertex-array-bit+ #x00000002) (defconstant +client-all-attrib-bits+ #xffffffff) ;; ARB Multitexturing extension (defconstant +arb-multitexture+ 1) (defconstant +texture0-arb+ #x84c0) (defconstant +texture1-arb+ #x84c1) (defconstant +texture2-arb+ #x84c2) (defconstant +texture3-arb+ #x84c3) (defconstant +texture4-arb+ #x84c4) (defconstant +texture5-arb+ #x84c5) (defconstant +texture6-arb+ #x84c6) (defconstant +texture7-arb+ #x84c7) (defconstant +texture8-arb+ #x84c8) (defconstant +texture9-arb+ #x84c9) (defconstant +texture10-arb+ #x84ca) (defconstant +texture11-arb+ #x84cb) (defconstant +texture12-arb+ #x84cc) (defconstant +texture13-arb+ #x84cd) (defconstant +texture14-arb+ #x84ce) (defconstant +texture15-arb+ #x84cf) (defconstant +texture16-arb+ #x84d0) (defconstant +texture17-arb+ #x84d1) (defconstant +texture18-arb+ #x84d2) (defconstant +texture19-arb+ #x84d3) (defconstant +texture20-arb+ #x84d4) (defconstant +texture21-arb+ #x84d5) (defconstant +texture22-arb+ #x84d6) (defconstant +texture23-arb+ #x84d7) (defconstant +texture24-arb+ #x84d8) (defconstant +texture25-arb+ #x84d9) (defconstant +texture26-arb+ #x84da) (defconstant +texture27-arb+ #x84db) (defconstant +texture28-arb+ #x84dc) (defconstant +texture29-arb+ #x84dd) (defconstant +texture30-arb+ #x84de) (defconstant +texture31-arb+ #x84df) (defconstant +active-texture-arb+ #x84e0) (defconstant +client-active-texture-arb+ #x84e1) (defconstant +max-texture-units-arb+ #x84e2) ;;; Misc extensions (defconstant +ext-abgr+ 1) (defconstant +abgr-ext+ #x8000) (defconstant +ext-blend-color+ 1) (defconstant +constant-color-ext+ #x8001) (defconstant +one-minus-constant-color-ext+ #x8002) (defconstant +constant-alpha-ext+ #x8003) (defconstant +one-minus-constant-alpha-ext+ #x8004) (defconstant +blend-color-ext+ #x8005) (defconstant +ext-polygon-offset+ 1) (defconstant +polygon-offset-ext+ #x8037) (defconstant +polygon-offset-factor-ext+ #x8038) (defconstant +polygon-offset-bias-ext+ #x8039) (defconstant +ext-texture3d+ 1) (defconstant +pack-skip-images-ext+ #x806b) (defconstant +pack-image-height-ext+ #x806c) (defconstant +unpack-skip-images-ext+ #x806d) (defconstant +unpack-image-height-ext+ #x806e) (defconstant +texture-3d-ext+ #x806f) (defconstant +proxy-texture-3d-ext+ #x8070) (defconstant +texture-depth-ext+ #x8071) (defconstant +texture-wrap-r-ext+ #x8072) (defconstant +max-3d-texture-size-ext+ #x8073) (defconstant +texture-3d-binding-ext+ #x806a) (defconstant +ext-texture-object+ 1) (defconstant +texture-priority-ext+ #x8066) (defconstant +texture-resident-ext+ #x8067) (defconstant +texture-1d-binding-ext+ #x8068) (defconstant +texture-2d-binding-ext+ #x8069) (defconstant +ext-rescale-normal+ 1) (defconstant +rescale-normal-ext+ #x803a) (defconstant +ext-vertex-array+ 1) (defconstant +vertex-array-ext+ #x8074) (defconstant +normal-array-ext+ #x8075) (defconstant +color-array-ext+ #x8076) (defconstant +index-array-ext+ #x8077) (defconstant +texture-coord-array-ext+ #x8078) (defconstant +edge-flag-array-ext+ #x8079) (defconstant +vertex-array-size-ext+ #x807a) (defconstant +vertex-array-type-ext+ #x807b) (defconstant +vertex-array-stride-ext+ #x807c) (defconstant +vertex-array-count-ext+ #x807d) (defconstant +normal-array-type-ext+ #x807e) (defconstant +normal-array-stride-ext+ #x807f) (defconstant +normal-array-count-ext+ #x8080) (defconstant +color-array-size-ext+ #x8081) (defconstant +color-array-type-ext+ #x8082) (defconstant +color-array-stride-ext+ #x8083) (defconstant +color-array-count-ext+ #x8084) (defconstant +index-array-type-ext+ #x8085) (defconstant +index-array-stride-ext+ #x8086) (defconstant +index-array-count-ext+ #x8087) (defconstant +texture-coord-array-size-ext+ #x8088) (defconstant +texture-coord-array-type-ext+ #x8089) (defconstant +texture-coord-array-stride-ext+ #x808a) (defconstant +texture-coord-array-count-ext+ #x808b) (defconstant +edge-flag-array-stride-ext+ #x808c) (defconstant +edge-flag-array-count-ext+ #x808d) (defconstant +vertex-array-pointer-ext+ #x808e) (defconstant +normal-array-pointer-ext+ #x808f) (defconstant +color-array-pointer-ext+ #x8090) (defconstant +index-array-pointer-ext+ #x8091) (defconstant +texture-coord-array-pointer-ext+ #x8092) (defconstant +edge-flag-array-pointer-ext+ #x8093) (defconstant +sgis-texture-edge-clamp+ 1) (defconstant +clamp-to-edge-sgis+ #x812f) (defconstant +ext-blend-minmax+ 1) (defconstant +func-add-ext+ #x8006) (defconstant +min-ext+ #x8007) (defconstant +max-ext+ #x8008) (defconstant +blend-equation-ext+ #x8009) (defconstant +ext-blend-subtract+ 1) (defconstant +func-subtract-ext+ #x800a) (defconstant +func-reverse-subtract-ext+ #x800b) (defconstant +ext-blend-logic-op+ 1) (defconstant +ext-point-parameters+ 1) (defconstant +point-size-min-ext+ #x8126) (defconstant +point-size-max-ext+ #x8127) (defconstant +point-fade-threshold-size-ext+ #x8128) (defconstant +distance-attenuation-ext+ #x8129) (defconstant +ext-paletted-texture+ 1) (defconstant +table-too-large-ext+ #x8031) (defconstant +color-table-format-ext+ #x80d8) (defconstant +color-table-width-ext+ #x80d9) (defconstant +color-table-red-size-ext+ #x80da) (defconstant +color-table-green-size-ext+ #x80db) (defconstant +color-table-blue-size-ext+ #x80dc) (defconstant +color-table-alpha-size-ext+ #x80dd) (defconstant +color-table-luminance-size-ext+ #x80de) (defconstant +color-table-intensity-size-ext+ #x80df) (defconstant +texture-index-size-ext+ #x80ed) (defconstant +color-index1-ext+ #x80e2) (defconstant +color-index2-ext+ #x80e3) (defconstant +color-index4-ext+ #x80e4) (defconstant +color-index8-ext+ #x80e5) (defconstant +color-index12-ext+ #x80e6) (defconstant +color-index16-ext+ #x80e7) (defconstant +ext-clip-volume-hint+ 1) (defconstant +clip-volume-clipping-hint-ext+ #x80f0) (defconstant +ext-compiled-vertex-array+ 1) (defconstant +array-element-lock-first-ext+ #x81a8) (defconstant +array-element-lock-count-ext+ #x81a9) (defconstant +hp-occlusion-test+ 1) (defconstant +occlusion-test-hp+ #x8165) (defconstant +occlusion-test-result-hp+ #x8166) (defconstant +ext-shared-texture-palette+ 1) (defconstant +shared-texture-palette-ext+ #x81fb) (defconstant +ext-stencil-wrap+ 1) (defconstant +incr-wrap-ext+ #x8507) (defconstant +decr-wrap-ext+ #x8508) (defconstant +nv-texgen-reflection+ 1) (defconstant +normal-map-nv+ #x8511) (defconstant +reflection-map-nv+ #x8512) (defconstant +ext-texture-env-add+ 1) (defconstant +mesa-window-pos+ 1) (defconstant +mesa-resize-buffers+ 1) ) ;;; Utility stuff (deftype bool () 'card8) (deftype float32 () 'single-float) (deftype float64 () 'double-float) (declaim (inline aset-float32 aset-float64)) #+sbcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (sb-kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+cmu (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (kernel:single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+openmcl (defun aset-float32 (value array index) (declare (type single-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((bits (ccl::single-float-bits value))) (declare (type (unsigned-byte 32) bits)) (aset-card32 bits array index)) value) #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (sb-kernel:double-float-low-bits value)) (high (sb-kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) #+cmu (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (let ((low (kernel:double-float-low-bits value)) (high (kernel:double-float-high-bits value))) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (+ index 4))) value) #+openmcl (defun aset-float64 (value array index) (declare (type double-float value) (type buffer-bytes array) (type array-index index)) #.(declare-buffun) (multiple-value-bind (low high) (ccl::double-float-bits value) (declare (type (unsigned-byte 32) low high)) (aset-card32 low array index) (aset-card32 high array (the array-index (+ index 4)))) value) (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type ((int8 card8 bool) 1) ((int16 card16) 2) ((int32 card32 float32) 4) ((float64) 8))) (defun setter (type) (ecase type (int8 'aset-int8) (int16 'aset-int16) (int32 'aset-int32) (bool 'aset-card8) (card8 'aset-card8) (card16 'aset-card16) (card32 'aset-card32) (float32 'aset-float32) (float64 'aset-float64))) (defun sequence-setter (type) (ecase type (int8 'sset-int8) (int16 'sset-int16) (int32 'sset-int32) (bool 'sset-card8) (card8 'sset-card8) (card16 'sset-card16) (card32 'sset-card32) (float32 'sset-float32) (float64 'sset-float64))) (defmacro define-sequence-setter (type) `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length) (declare (type sequence seq) (type buffer-bytes buffer) (type array-index start) (type fixnum length)) #.(declare-buffun) (assert (= length (length seq)) (length seq) "SEQUENCE length should be ~D, not ~D." length (length seq)) (typecase seq (list (let ((offset 0)) (declare (type fixnum offset)) (dolist (n seq) (declare (type ,type n)) (,(setter type) n buffer (the array-index (+ start offset))) (incf offset ,(byte-width type))))) ((simple-array ,type) (dotimes (i ,(byte-width type)) (,(setter type) (aref seq i) buffer (the array-index (+ start (* i ,(byte-width type))))))) (vector (dotimes (i ,(byte-width type)) (,(setter type) (svref seq i) buffer (the array-index (+ start (* i ,(byte-width type)))))))))) (define-sequence-setter int8) (define-sequence-setter int16) (define-sequence-setter int32) (define-sequence-setter bool) (define-sequence-setter card8) (define-sequence-setter card16) (define-sequence-setter card32) (define-sequence-setter float32) (define-sequence-setter float64) (defun make-argspecs (list) (destructuring-bind (name type) list (etypecase type (symbol `(,name ,type 1 nil)) (list `(,name ,(second type) ,(third type) ,(if (consp (third type)) (make-symbol (format nil "~A-~A" name 'length)) nil)))))) (defun byte-width-calculation (argspecs) (let ((constant 0) (calculated ())) (loop for (name type length length-var) in argspecs do (let ((byte-width (byte-width type))) (typecase length (number (incf constant (* byte-width length))) (symbol (push `(* ,byte-width ,length) calculated)) (cons (push `(* ,byte-width ,length-var) calculated))))) (if (null calculated) constant (list* '+ constant calculated)))) (defun composite-args (argspecs) (loop for (name type length length-var) in argspecs when (consp length) collect (list length-var length))) (defun make-setter-forms (argspecs) (loop for (name type length length-var) in argspecs collecting `(progn ,(if (and (numberp length) (= 1 length)) `(,(setter type) ,name .rbuf. .index.) `(,(sequence-setter type) ,name .rbuf. .index. ,(if length-var length-var length))) (setf .index. (the array-index (+ .index. (the fixnum (* ,(byte-width type) ,(if length-var length-var length))))))))) (defmacro define-rendering-command (name opcode &rest args) ;; FIXME: Must heavily type-annotate. (labels ((expand-args (list) (loop for (arg type) in list if (consp arg) append (loop for name in arg collecting (list name type)) else collect (list arg type)))) (let* ((args (expand-args args)) (argspecs (mapcar 'make-argspecs args)) (total-byte-width (byte-width-calculation argspecs)) (composite-args (composite-args argspecs))) `(defun ,name ,(mapcar #'first argspecs) (declare ,@(mapcar #'(lambda (list) (if (symbolp (second list)) (list* 'type (reverse list)) `(type sequence ,(first list)))) args)) #.(declare-buffun) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((.ctx. *current-context*) (.index0. (context-index .ctx.)) (.index. (+ .index0. 4)) (.rbuf. (context-rbuf .ctx.)) ,@composite-args (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4))))) (declare (type context .ctx.) (type array-index .index. .index0.) (type buffer-bytes .rbuf.) ,@(mapcar #'(lambda (list) `(type fixnum ,(first list))) composite-args) (type fixnum .length.)) (when (< (- (length .rbuf.) 8) (+ .index. .length.)) (error "Rendering command sequence too long. Implement automatic buffer flushing.")) (aset-card16 .length. .rbuf. (the array-index .index0.)) (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2))) ,@(make-setter-forms argspecs) (setf (context-index .ctx.) (the array-index (+ .index0. .length.)))))))) ) ;; eval-when ;;; Command implementation. (defun get-string (name) (assert (context-p *current-context*) (*current-context*) "*CURRENT-CONTEXT* is not set (~S)." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-string+) ;; *** This is CONTEXT-TAG (card32 (context-tag ctx)) ;; *** This is ENUM. (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) ;; FIXME: How does this interact with unicode? (map-into (make-string (1- length)) #'code-char bytes))))) ;;; Rendering commands (in alphabetical order). (define-rendering-command accum 137 ;; *** ENUM (op card32) (value float32)) (define-rendering-command active-texture-arb 197 ;; *** ENUM (texture card32)) (define-rendering-command alpha-func 159 ;; *** ENUM (func card32) (ref float32)) (define-rendering-command begin 4 ;; *** ENUM (mode card32)) (define-rendering-command bind-texture 4117 ;; *** ENUM (target card32) (texture card32)) (define-rendering-command blend-color 4096 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command blend-equotion 4097 ;; *** ENUM (mode card32)) (define-rendering-command blend-func 160 ;; *** ENUM (sfactor card32) ;; *** ENUM (dfactor card32)) (define-rendering-command call-list 1 (list card32)) (define-rendering-command clear 127 ;; *** BITFIELD (mask card32)) (define-rendering-command clear-accum 128 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-color 130 (red float32) (green float32) (blue float32) (alpha float32)) (define-rendering-command clear-depth 132 (depth float64)) (define-rendering-command clear-index 129 (c float32)) (define-rendering-command clear-stencil 131 (s int32)) (define-rendering-command clip-plane 77 (equotion-0 float64) (equotion-1 float64) (equotion-2 float64) (equotion-3 float64) ;; *** ENUM (plane card32)) (define-rendering-command color-3b 6 ((r g b) int8)) (define-rendering-command color-3d 7 ((r g b) float64)) (define-rendering-command color-3f 8 ((r g b) float32)) (define-rendering-command color-3i 9 ((r g b) int32)) (define-rendering-command color-3s 10 ((r g b) int16)) (define-rendering-command color-3ub 11 ((r g b) card8)) (define-rendering-command color-3ui 12 ((r g b) card32)) (define-rendering-command color-3us 13 ((r g b) card16)) (define-rendering-command color-4b 14 ((r g b a) int8)) (define-rendering-command color-4d 15 ((r g b a) float64)) (define-rendering-command color-4f 16 ((r g b a) float32)) (define-rendering-command color-4i 17 ((r g b a) int32)) (define-rendering-command color-4s 18 ((r g b a) int16)) (define-rendering-command color-4ub 19 ((r g b a) card8)) (define-rendering-command color-4ui 20 ((r g b a) card32)) (define-rendering-command color-4us 21 ((r g b a) card16)) (define-rendering-command color-mask 134 (red bool) (green bool) (blue bool) (alpha bool)) (define-rendering-command color-material 78 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command color-table-parameter-fv 2054 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list float32 4))) (define-rendering-command color-table-parameter-iv 2055 ;; *** ENUM (target card32) ;; TODO: ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4 ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4 ;; else (length params) = 0 (command is erronous) ;; *** ENUM (pname card32) (params (list int32 4))) (define-rendering-command convolution-parameter-f 4103 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params float32)) (define-rendering-command convolution-parameter-fv 4104 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-width+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command convolution-parameter-i 4105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params int32)) (define-rendering-command convolution-parameter-iv 4106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+convolution-border-mode+ #.+convolution-format+ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ #.+max-convolution-width+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) 4))))) (define-rendering-command copy-color-sub-table 196 ;; *** ENUM (target card32) (start int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-color-table 2056 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-id 4107 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32)) (define-rendering-command copy-convolution-filter-2d 4108 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-pixels 172 (x int32) (y int32) (width int32) (height int32) ;; *** ENUM (type card32)) (define-rendering-command copy-tex-image-1d 4119 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (border int32)) (define-rendering-command copy-tex-image-2d 4120 ;; *** ENUM (target card32) (level int32) ;; *** ENUM (internalformat card32) (x int32) (y int32) (width int32) (height int32) (border int32)) (define-rendering-command copy-tex-sub-image-1d 4121 ;; *** ENUM (target card32) (level int32) (xoffset int32) (x int32) (y int32) (width int32)) (define-rendering-command copy-tex-sub-image-2d 4122 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command copy-tex-sub-image-3d 4123 ;; *** ENUM (target card32) (level int32) (xoffset int32) (yoffset int32) (zoffset int32) (x int32) (y int32) (width int32) (height int32)) (define-rendering-command cull-face 79 ;; *** ENUM (mode card32)) (define-rendering-command depth-func 164 ;; *** ENUM (func card32)) (define-rendering-command depth-mask 135 (mask bool)) (define-rendering-command depth-range 174 (z-near float64) (z-far float64)) (define-rendering-command draw-buffer 126 ;; *** ENUM (mode card32)) (define-rendering-command edge-flag-v 22 (flag-0 bool)) (define-rendering-command end 23) (define-rendering-command eval-coord-1d 151 (u-0 float64)) (define-rendering-command eval-coord-1f 152 (u-0 float32)) (define-rendering-command eval-coord-2d 153 ((u-0 u-1) float64)) (define-rendering-command eval-coord-2f 154 ((u-0 u-1) float32)) (define-rendering-command eval-mesh-1 155 ;; *** ENUM (mode card32) ((i1 i2) int32)) (define-rendering-command eval-mesh-2 157 ;; *** ENUM (mode card32) ((i1 i2 j1 j2) int32)) (define-rendering-command eval-point-1 156 (i int32)) (define-rendering-command eval-point-2 158 (i int32) (j int32)) (define-rendering-command fog-f 80 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command fog-fv 81 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command fog-i 82 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command fog-iv 83 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+fog-index+ #.+fog-density+ #.+fog-start+ #.+fog-end+ #.+fog-mode+) 1) ((#.+fog-color+) 4))))) (define-rendering-command front-face 84 ;; *** ENUM (mode card32)) (define-rendering-command frustum 175 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command hint 85 ;; *** ENUM (target card32) ;; *** ENUM (mode card32)) (define-rendering-command histogram 4110 ;; *** ENUM (target card32) (width int32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command index-mask 136 (mask card32)) (define-rendering-command index-d 24 (c-0 float64)) (define-rendering-command index-f 25 (c-0 float32)) (define-rendering-command index-i 26 (c-0 int32)) (define-rendering-command index-s 27 (c-0 int16)) (define-rendering-command index-ub 194 (c-0 card8)) (define-rendering-command init-names 121) (define-rendering-command light-model-f 90 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-model-fv 91 ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-model-i 92 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-model-iv 93 ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+light-model-color-control+ #.+light-model-local-viewer+ #.+light-model-two-side+) 1) ((#.+light-model-ambient+) 4))))) (define-rendering-command light-f 86 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command light-fv 87 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command light-i 88 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command light-iv 89 ;; *** ENUM (light card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+position+) 4) ((#.+spot-direction+) 3) ((#.+spot-exponent+ #.+spot-cutoff+ #.+constant-attenuation+ #.+linear-attenuation+ #.+quadratic-attenuation+) 1))))) (define-rendering-command line-stipple 94 (factor int32) (pattern card16)) (define-rendering-command line-width 95 (width float32)) (define-rendering-command list-base 3 (base card32)) (define-rendering-command load-identity 176) (define-rendering-command load-matrix-d 178 (m (list float64 16))) (define-rendering-command load-matrix-f 177 (m (list float32 16))) (define-rendering-command load-name 122 (name card32)) (define-rendering-command logic-op 161 ;; *** ENUM (name card32)) (define-rendering-command map-grid-1d 147 (u1 float64) (u2 float64) (un int32)) (define-rendering-command map-grid-1f 148 (un int32) (u1 float32) (u2 float32)) (define-rendering-command map-grid-2d 149 (u1 float64) (u2 float64) (v1 float64) (v2 float64) (un int32) (vn int32)) (define-rendering-command map-grid-2f 150 (un int32) (u1 float32) (u2 float32) (vn int32) (v1 float32) (v2 float32)) (define-rendering-command material-f 96 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command material-fv 97 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command material-i 98 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command material-iv 99 ;; *** ENUM (face card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+ambient+ #.+diffuse+ #.+specular+ #.+emission+ #.+ambient-and-diffuse+) 4) ((#.+shininess+) 1) ((#.+color-index+) 3))))) (define-rendering-command matrix-mode 179 ;; *** ENUM (mode card32)) (define-rendering-command minmax 4111 ;; *** ENUM (target card32) ;; *** ENUM (internalformat card32) (sink bool)) (define-rendering-command mult-matrix-d 181 (m (list float64 16))) (define-rendering-command mult-matrix-f 180 (m (list float32 16))) ;;; *** Note that TARGET is placed last for FLOAT64 versions. (define-rendering-command multi-tex-coord-1d-arb 198 (v-0 float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-1f-arb 199 ;; *** ENUM (target card32) (v-0 float32)) (define-rendering-command multi-tex-coord-1i-arb 200 ;; *** ENUM (target card32) (v-0 int32)) (define-rendering-command multi-tex-coord-1s-arb 201 ;; *** ENUM (target card32) (v-0 int16)) (define-rendering-command multi-tex-coord-2d-arb 202 ((v-0 v-1) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-2f-arb 203 ;; *** ENUM (target card32) ((v-0 v-1) float32)) (define-rendering-command multi-tex-coord-2i-arb 204 ;; *** ENUM (target card32) ((v-0 v-1) int32)) (define-rendering-command multi-tex-coord-2s-arb 205 ;; *** ENUM (target card32) ((v-0 v-1) int16)) (define-rendering-command multi-tex-coord-3d-arb 206 ((v-0 v-1 v-2) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-3f-arb 207 ;; *** ENUM (target card32) ((v-0 v-1 v-2) float32)) (define-rendering-command multi-tex-coord-3i-arb 208 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int32)) (define-rendering-command multi-tex-coord-3s-arb 209 ;; *** ENUM (target card32) ((v-0 v-1 v-2) int16)) (define-rendering-command multi-tex-coord-4d-arb 210 ((v-0 v-1 v-2 v-3) float64) ;; *** ENUM (target card32)) (define-rendering-command multi-tex-coord-4f-arb 211 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command multi-tex-coord-4i-arb 212 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command multi-tex-coord-4s-arb 213 ;; *** ENUM (target card32) ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command normal-3b 28 ((v-0 v-1 v-2) int8)) (define-rendering-command normal-3d 29 ((v-0 v-1 v-2) float64)) (define-rendering-command normal-3f 30 ((v-0 v-1 v-2) float32)) (define-rendering-command normal-3i 31 ((v-0 v-1 v-2) int32)) (define-rendering-command normal-3s 32 ((v-0 v-1 v-2) int16)) (define-rendering-command ortho 182 (left float64) (right float64) (bottom float64) (top float64) (z-near float64) (z-far float64)) (define-rendering-command pass-through 123 (token float32)) (define-rendering-command pixel-transfer-f 166 ;; *** ENUM (pname card32) (param float32)) (define-rendering-command pixel-transfer-i 167 ;; *** ENUM (pname card32) (param int32)) (define-rendering-command pixel-zoom 165 (xfactor float32) (yfactor float32)) (define-rendering-command point-size 100 (size float32)) (define-rendering-command polygon-mode 101 ;; *** ENUM (face card32) ;; *** ENUM (mode card32)) (define-rendering-command polygon-offset 192 (factor float32) (units float32)) (define-rendering-command pop-attrib 141) (define-rendering-command pop-matrix 183) (define-rendering-command pop-name 124) (define-rendering-command prioritize-textures 4118 (n int32) (textures (list card32 n)) (priorities (list float32 n))) (define-rendering-command push-attrib 142 ;; *** BITFIELD (mask card32)) (define-rendering-command push-matrix 184) (define-rendering-command push-name 125 (name card32)) (define-rendering-command raster-pos-2d 33 ((v-0 v-1) float64)) (define-rendering-command raster-pos-2f 34 ((v-0 v-1) float32)) (define-rendering-command raster-pos-2i 35 ((v-0 v-1) int32)) (define-rendering-command raster-pos-2s 36 ((v-0 v-1) int16)) (define-rendering-command raster-pos-3d 37 ((v-0 v-1 v-2) float64)) (define-rendering-command raster-pos-3f 38 ((v-0 v-1 v-2) float32)) (define-rendering-command raster-pos-3i 39 ((v-0 v-1 v-2) int32)) (define-rendering-command raster-pos-3s 40 ((v-0 v-1 v-2) int16)) (define-rendering-command raster-pos-4d 41 ((v-0 v-1 v-2 v-3) float64)) (define-rendering-command raster-pos-4f 42 ((v-0 v-1 v-2 v-3) float32)) (define-rendering-command raster-pos-4i 43 ((v-0 v-1 v-2 v-3) int32)) (define-rendering-command raster-pos-4s 44 ((v-0 v-1 v-2 v-3) int16)) (define-rendering-command read-buffer 171 ;; *** ENUM (mode card32)) (define-rendering-command rect-d 45 ((v1-0 v1-1 v2-0 v2-1) float64)) (define-rendering-command rect-f 46 ((v1-0 v1-1 v2-0 v2-1) float32)) (define-rendering-command rect-i 47 ((v1-0 v1-1 v2-0 v2-1) int32)) (define-rendering-command rect-s 48 ((v1-0 v1-1 v2-0 v2-1) int16)) (define-rendering-command reset-histogram 4112 ;; *** ENUM (target card32)) (define-rendering-command reset-minmax 4113 ;; *** ENUM (target card32)) (define-rendering-command rotate-d 185 ((angle x y z) float64)) (define-rendering-command rotate-f 186 ((angle x y z) float32)) (define-rendering-command scale-d 187 ((x y z) float64)) (define-rendering-command scale-f 188 ((x y z) float32)) (define-rendering-command scissor 103 ((x y width height) int32)) (define-rendering-command shade-model 104 ;; *** ENUM (mode card32)) (define-rendering-command stencil-func 162 ;; *** ENUM (func card32) (ref int32) (mask card32)) (define-rendering-command stencil-mask 133 (mask card32)) (define-rendering-command stencil-op 163 ;; *** ENUM (fail card32) ;; *** ENUM (zfail card32) ;; *** ENUM (zpass card32)) (define-rendering-command tex-env-f 111 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-env-fv 112 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list float32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) (define-rendering-command tex-env-i 113 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-env-iv 114 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param (list int32 (ecase pname (#.+texture-env-mode+ 1) (#.+texture-env-color+ 4))))) ;;; *** ;;; last there. (define-rendering-command tex-gen-d 115 (param float64) ;; *** ENUM (coord card32) ;; *** ENUM (pname card32)) (define-rendering-command tex-gen-dv 116 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) ;; +texture-gen-mode+ n=1 ;; +object-plane+ n=4 ;; +eye-plane+ n=1 (params (list float64 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-f 117 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-gen-fv 118 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-gen-i 119 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-gen-iv 120 ;; *** ENUM (coord card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-gen-mode+ #.+eye-plane+) 1) (#.+object-plane+ 4))))) (define-rendering-command tex-parameter-f 105 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param float32)) (define-rendering-command tex-parameter-fv 106 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list float32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command tex-parameter-i 107 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (param int32)) (define-rendering-command tex-parameter-iv 108 ;; *** ENUM (target card32) ;; *** ENUM (pname card32) (params (list int32 (ecase pname ((#.+texture-border-color+) 4) ((#.+texture-mag-filter+ #.+texture-min-filter+ #.+texture-wrap-s+ #.+texture-wrap-t+) 1))))) (define-rendering-command translate-d 189 ((x y z) float64)) (define-rendering-command translate-f 190 ((x y z) float32)) (define-rendering-command vertex-2d 65 ((x y) float64)) (define-rendering-command vertex-2f 66 ((x y) float32)) (define-rendering-command vertex-2i 67 ((x y) int32)) (define-rendering-command vertex-2s 68 ((x y) int16)) (define-rendering-command vertex-3d 69 ((x y z) float64)) (define-rendering-command vertex-3f 70 ((x y z) float32)) (define-rendering-command vertex-3i 71 ((x y z) int32)) (define-rendering-command vertex-3s 72 ((x y z) int16)) (define-rendering-command vertex-4d 73 ((x y z w) float64)) (define-rendering-command vertex-4f 74 ((x y z w) float32)) (define-rendering-command vertex-4i 75 ((x y z w) int32)) (define-rendering-command vertex-4s 76 ((x y z w) int16)) (define-rendering-command viewport 191 ((x y width height) int32)) ;;; Potentially lerge rendering commands. #-(and) (define-large-rendering-command call-lists 2 (n int32) ;; *** ENUM (type card32) (lists (list type n))) ;;; Requests for GL non-rendering commands. (defun new-list (list mode) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +new-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (card32 list) ;; *** ENUM (card32 mode)))) (defun gen-lists (range) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +gen-lists+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (integer range)) (card32-get 8)))) (defun end-list () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +end-list+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun enable (cap) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +enable+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) ;; *** ENUM? (card32 cap))))) ;;; FIXME: FLUSH and FINISH should send *all* buffered data, including ;;; buffered rendering commands. (defun flush () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +flush+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun finish () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +finish+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)))))) cmucl-21a/src/clx/glx.lisp000066400000000000000000000534111260377556400156250ustar00rootroot00000000000000#+cmu (ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (defpackage :glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" "DEF-CLX-CLASS" "DECLARE-EVENT" "ALLOCATE-RESOURCE-ID" "DEALLOCATE-RESOURCE-ID" "PRINT-DISPLAY-NAME" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "READ-CARD32" "WRITE-CARD32" "CARD32-GET" "CARD8-GET" "SEQUENCE-GET" "SEQUENCE-PUT" "DATA" ;; Types "ARRAY-INDEX" "BUFFER-BYTES" "WITH-DISPLAY" "BUFFER-FLUSH" "BUFFER-WRITE" "BUFFER-FORCE-OUTPUT" "ASET-CARD8" "ASET-CARD16" "ASET-CARD32" ) (:export ;; Constants "+VENDOR+" "+VERSION+" "+EXTENSIONS+" ;; Conditions "BAD-CONTEXT" "BAD-CONTEXT-STATE" "BAD-DRAWABLE" "BAD-PIXMAP" "BAD-CONTEXT-TAG" "BAD-CURRENT-WINDOW" "BAD-RENDER-REQUEST" "BAD-LARGE-REQUEST" "UNSUPPORTED-PRIVATE-REQUEST" "BAD-FB-CONFIG" "BAD-PBUFFER" "BAD-CURRENT-DRAWABLE" "BAD-WINDOW" ;; Requests "QUERY-VERSION" "QUERY-SERVER-STRING" "CREATE-CONTEXT" "DESTROY-CONTEXT" "IS-DIRECT" "QUERY-CONTEXT" "GET-DRAWABLE-ATTRIBUTES" "MAKE-CURRENT" ;;"GET-VISUAL-CONFIGS" "CHOOSE-VISUAL" "VISUAL-ATTRIBUTE" "VISUAL-ID" "RENDER" "SWAP-BUFFERS" "WAIT-GL" "WAIT-X" )) (in-package :glx) (declaim (optimize (debug 3) (safety 3))) (define-extension "GLX" :events (:glx-pbuffer-clobber) :errors (bad-context bad-context-state bad-drawable bad-pixmap bad-context-tag bad-current-window bad-render-request bad-large-request unsupported-private-request bad-fb-config bad-pbuffer bad-current-drawable bad-window)) ;;; Opcodes. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +render+ 1) (defconstant +create-context+ 3) (defconstant +destroy-context+ 4) (defconstant +make-current+ 5) (defconstant +is-direct+ 6) (defconstant +query-version+ 7) (defconstant +wait-gl+ 8) (defconstant +wait-x+ 9) (defconstant +copy-context+ 10) (defconstant +swap-buffers+ 11) (defconstant +get-visual-configs+ 14) (defconstant +destroy-glx-pixmap+ 15) (defconstant +query-server-string+ 19) (defconstant +client-info+ 20) (defconstant +get-fb-configs+ 21) (defconstant +query-context+ 25) (defconstant +get-drawable-attributes+ 29) ) ;;; Constants (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +vendor+ 1) (defconstant +version+ 2) (defconstant +extensions+ 3) ) ;;; Types ;;; FIXME: ;;; - Are all the 32-bit values unsigned? Do we care? ;;; - These are not used much, yet. (progn (deftype attribute-pair ()) (deftype bitfield () 'mask32) (deftype bool32 () 'card32) ; 1 for true and 0 for false (deftype enum () 'card32) (deftype fbconfigid () 'card32) ;; FIXME: How to define these two? (deftype float32 () 'single-float) (deftype float64 () 'double-float) ;;(deftype glx-context () 'card32) (deftype context-tag () 'card32) ;;(deftype glx-drawable () 'card32) (deftype glx-pixmap () 'card32) (deftype glx-pbuffer () 'card32) (deftype glx-render-command () #|TODO|#) (deftype glx-window () 'card32) #-(and) (deftype visual-property () "An ordered list of 32-bit property values followed by unordered pairs of property types and property values." ;; FIXME: maybe CLX-LIST or even just LIST? 'clx-sequence)) ;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package ;;; (using XINTERN). Therefore the accessors defined below can only ;;; be accessed using double-colon, which is a bad style. Or these ;;; forms must be taken to another file so the accessors exist before ;;; we get to this file. #-(and) (define-accessor glx-context-tag (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) #-(and) (define-accessor glx-enum (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) ;;; FIXME: I'm just not sure we need a seperate accessors for what ;;; essentially are aliases for other types. Maybe use compiler ;;; macros? ;;; ;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a ;;; known accessor. The only trick left I think is to change the ;;; XINTERN function to intern the new symbols in the same package as ;;; he symbol part of it comes from. Don't know if it would break ;;; anything, thought. (I would be quite surprised if it did -- there ;;; is only one package in CLX after all: XLIB.) ;;; ;;; I also found the origin of the error (about symbol not being a ;;; known accessor): INDEX-INCREMENT function. Looks like all we have ;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol ;;; plist. But accessors are macros, not functions, anyway. #-(and) (progn (declaim (inline context-tag-get context-tag-put enum-get enum-put)) (defun context-tag-get (index) (card32-get index)) (defun context-tag-put (index thing) (card32-put index thing)) (defun enum-get (index) (card32-get index)) (defun enum-put (index thing) (card32-put index thing)) ) ;;; Structures (def-clx-class (context (:constructor %make-context) (:print-function print-context) (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (tag 0 :type card32) (drawable nil :type (or null drawable)) ;; TODO: There can only be one current context (as far as I ;; understand). If so, we'd need only one buffer (otherwise it's a ;; big waste to have a quarter megabyte buffer for each context; or ;; we could allocate/grow the buffer on demand). ;; ;; 256k buffer for Render command. Big requests are served with ;; RenderLarge command. First 8 octets are Render request fields. ;; (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes) ;; Index into RBUF where the next rendering command should be inserted. (index 8 :type array-index)) (defun print-context (ctx stream depth) (declare (type context ctx) (ignore depth)) (print-unreadable-object (ctx stream :type t) (print-display-name (context-display ctx) stream) (write-string " " stream) (princ (context-id ctx) stream))) (def-clx-class (visual (:constructor %make-visual) (:print-function print-visual) (:copier nil)) (id 0 :type resource-id) (attributes nil :type list)) (defun print-visual (visual stream depth) (declare (type visual visual) (ignore depth)) (print-unreadable-object (visual stream :type t) (write-string "ID: " stream) (princ (visual-id visual) stream) (write-string " " stream) (princ (visual-attributes visual) stream))) ;;; Events. (defconstant +damaged+ #x8017) (defconstant +saved+ #x8018) (defconstant +window+ #x8019) (defconstant +pbuffer+ #x801a) (declare-event :glx-pbuffer-clobber (card16 sequence) (card16 event-type) ;; +DAMAGED+ or +SAVED+ (card16 draw-type) ;; +WINDOW+ or +PBUFFER+ (resource-id drawable) ;; FIXME: (bitfield buffer-mask) (card32 buffer-mask) (card16 aux-buffer) (card16 x y width height count)) ;;; Errors. (define-condition bad-context (request-error) ()) (define-condition bad-context-state (request-error) ()) (define-condition bad-drawable (request-error) ()) (define-condition bad-pixmap (request-error) ()) (define-condition bad-context-tag (request-error) ()) (define-condition bad-current-window (request-error) ()) (define-condition bad-render-request (request-error) ()) (define-condition bad-large-request (request-error) ()) (define-condition unsupported-private-request (request-error) ()) (define-condition bad-fb-config (request-error) ()) (define-condition bad-pbuffer (request-error) ()) (define-condition bad-current-drawable (request-error) ()) (define-condition bad-window (request-error) ()) (define-error bad-context decode-core-error) (define-error bad-context-state decode-core-error) (define-error bad-drawable decode-core-error) (define-error bad-pixmap decode-core-error) (define-error bad-context-tag decode-core-error) (define-error bad-current-window decode-core-error) (define-error bad-render-request decode-core-error) (define-error bad-large-request decode-core-error) (define-error unsupported-private-request decode-core-error) (define-error bad-fb-config decode-core-error) (define-error bad-pbuffer decode-core-error) (define-error bad-current-drawable decode-core-error) (define-error bad-window decode-core-error) ;;; Requests. (defun query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-version+) (card32 1) (card32 3)) (values (card32-get 8) (card32-get 12)))) (defun query-server-string (display screen name) "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+" (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-server-string+) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (card32 name)) (let* ((length (card32-get 12)) (bytes (sequence-get :format card8 :result-type '(simple-array card8 (*)) :index 32 :length length))) (declare (type (simple-array card8 (*)) bytes) (type fixnum length)) (map-into (make-string (1- length)) #'code-char bytes)))) (defun client-info (display) ;; TODO: This should be invoked automatically when using this ;; library in initialization stage. ;; ;; TODO: No extensions supported yet. ;; ;; *** Maybe the LENGTH field must be filled in some special way ;; (similar to data)? (with-buffer-request (display (extension-opcode display "GLX")) (data +client-info+) (card32 4) ; length of the request (card32 1) ; major (card32 3) ; minor (card32 0) ; n )) ;;; XXX: This looks like an internal thing. Should name appropriately. (defun make-context (display) (let ((ctx (%make-context :display display))) (setf (context-id ctx) (allocate-resource-id display ctx 'context)) ;; Prepare render request buffer. ctx)) (defun create-context (screen visual &optional (share-list 0) (is-direct nil)) "Do NOT use the direct mode, yet!" (let* ((root (screen-root screen)) (display (drawable-display root)) (ctx (make-context display))) (with-buffer-request (display (extension-opcode display "GLX")) (data +create-context+) (resource-id (context-id ctx)) (resource-id visual) (card32 (or (position screen (display-roots display) :test #'eq) 0)) (resource-id share-list) (boolean is-direct)) ctx)) ;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only? ;;; (defvar *current-context* nil) (defun destroy-context (ctx) (let ((id (context-id ctx)) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +destroy-context+) (resource-id id)) (deallocate-resource-id display id 'context) (setf (context-id ctx) 0) (when (eq ctx *current-context*) (setf *current-context* nil)))) (defun is-direct (ctx) (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +is-direct+) (resource-id (context-id ctx))) (card8-get 8)))) (defun query-context (ctx) ;; TODO: What are the attribute types? (let ((display (context-display ctx))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +query-context+) (resource-id (context-id ctx))) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) (defun get-drawable-attributes (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-drawable-attributes+) (drawable drawable)) (let ((num-attributes (card32-get 8))) ;; FIXME: Is this really so? (declare (type fixnum num-attributes)) (loop repeat num-attributes for i fixnum upfrom 32 by 8 collecting (cons (card32-get i) (card32-get (+ i 4)))))))) ;;; TODO: What is the idea behind passing drawable to this function? ;;; Can a context be made current for different drawables at different ;;; times? (Man page on glXMakeCurrent says that context's viewport ;;; is set to the size of drawable when creating; it does not change ;;; afterwards.) ;;; (defun make-current (drawable ctx) (let ((display (drawable-display drawable)) (old-tag (if *current-context* (context-tag *current-context*) 0))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +make-current+) (resource-id (drawable-id drawable)) (resource-id (context-id ctx)) ;; *** CARD32 is really a CONTEXT-TAG (card32 old-tag)) (let ((new-tag (card32-get 8))) (setf (context-tag ctx) new-tag (context-drawable ctx) drawable (context-display ctx) display *current-context* ctx))))) ;;; FIXME: Decide how to represent and use these. (eval-when (:load-toplevel :compile-toplevel :execute) (macrolet ((generate-config-properties () (let ((list '((:glx-visual visual-id) (:glx-class card32) (:glx-rgba bool32) (:glx-red-size card32) (:glx-green-size card32) (:glx-blue-size card32) (:glx-alpha-size card32) (:glx-accum-red-size card32) (:glx-accum-green-size card32) (:glx-accum-blue-size card32) (:glx-accum-alpha-size card32) (:glx-double-buffer bool32) (:glx-stereo bool32) (:glx-buffer-size card32) (:glx-depth-size card32) (:glx-stencil-size card32) (:glx-aux-buffers card32) (:glx-level int32)))) `(progn ,@(loop for (symbol type) in list collect `(setf (get ',symbol 'visual-config-property-type) ',type)) (defparameter *visual-config-properties* (map 'vector #'car ',list)) (declaim (type simple-vector *visual-config-properties*)) (deftype visual-config-property () '(member ,@(mapcar #'car list))))))) (generate-config-properties))) (defun make-visual (attributes) (let ((id-cons (first attributes))) (assert (eq :glx-visual (car id-cons)) (id-cons) "GLX visual id must be first in attributes list!") (%make-visual :id (cdr id-cons) :attributes (rest attributes)))) (defun visual-attribute (visual attribute) (assert (or (numberp attribute) (find attribute *visual-config-properties*)) (attribute) "~S is not a known GLX visual attribute." attribute) (cdr (assoc attribute (visual-attributes visual)))) ;;; TODO: Make this return nice structured objects with field values of correct type. ;;; FIXME: Looks like every other result is corrupted. (defun get-visual-configs (screen) (let ((display (drawable-display (screen-root screen)))) (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil) ((data +get-visual-configs+) (card32 (or (position screen (display-roots display) :test #'eq) 0))) (let* ((num-visuals (card32-get 8)) (num-properties (card32-get 12)) (num-ordered (length *visual-config-properties*))) ;; FIXME: Is this really so? (declare (type fixnum num-ordered num-visuals num-properties)) (loop with index fixnum = 28 repeat num-visuals collecting (make-visual (nconc (when (<= num-ordered num-properties) (map 'list #'(lambda (property) (cons property (card32-get (incf index 4)))) *visual-config-properties*)) (when (< num-ordered num-properties) (loop repeat (/ (- num-properties num-ordered) 2) collecting (cons (card32-get (incf index 4)) (card32-get (incf index 4)))))))))))) (defun choose-visual (screen attributes) "ATTRIBUTES is a list of desired attributes for a visual. The elements may be either a symbol, which means that the boolean attribute with that name must be true; or it can be a list of the form: (attribute-name value &optional (test '<=)) which means that the attribute named attribute-name must satisfy the test when applied to the given value and attribute's value in visual. Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." ;; TODO: Add type checks ;; ;; TODO: This function checks only supplied attributes; should check ;; all attributes, with default for boolean type being false, and ;; for number types zero. ;; ;; TODO: Make this smarter, like the docstring says, instead of ;; parrotting the inflexible C API. ;; (flet ((visual-matches-p (visual attributes) (dolist (attribute attributes t) (etypecase attribute (symbol (not (null (visual-attribute visual attribute)))) (cons (<= (second attribute) (visual-attribute visual (car attribute)))))))) (let* ((visuals (get-visual-configs screen)) (candidates (loop for visual in visuals when (visual-matches-p visual attributes) collect visual)) (result (first candidates))) (dolist (candidate (rest candidates)) ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color) ;; are preferred over glx-class 2 (static-color) and 5 (direct-color). (let ((class (visual-attribute candidate :glx-class))) (when (or (= class 3) (= class 4)) (setf result candidate)))) result))) (defun render () (declare (optimize (debug 3))) (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx)) (rbuf (context-rbuf ctx)) (index (context-index ctx))) (declare (type buffer-bytes rbuf) (type array-index index)) (when (< 8 index) (with-display (display) ;; Flush display's buffer first so we don't get messed up with X requests. (buffer-flush display) ;; First, update the Render request fields. (aset-card8 (extension-opcode display "GLX") rbuf 0) (aset-card8 1 rbuf 1) (aset-card16 (ceiling index 4) rbuf 2) (aset-card32 (context-tag ctx) rbuf 4) ;; Then send the request. (buffer-write rbuf display 0 (context-index ctx)) ;; Start filling from the beginning (setf (context-index ctx) 8))) (values))) (defun swap-buffers () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. (glx:render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx)) (resource-id (drawable-id (context-drawable ctx)))) (display-force-output display))) ;;; FIXME: These two are more complicated than sending messages. As I ;;; understand it, wait-gl should inhibit any X requests until all GL ;;; requests are sent... (defun wait-gl () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-gl+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) (defun wait-x () (assert (context-p *current-context*) (*current-context*) "~S is not a context." *current-context*) (let* ((ctx *current-context*) (display (context-display ctx))) (with-buffer-request (display (extension-opcode display "GLX")) (data +wait-x+) ;; *** GLX_CONTEXT_TAG (card32 (context-tag ctx))))) cmucl-21a/src/clx/graphics.lisp000066400000000000000000000411441260377556400166330ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; CLX drawing requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: graphics.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defvar *inhibit-appending* nil) (defun draw-point (drawable gcontext x y) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y)) (let ((display (drawable-display drawable))) (declare (type display display)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (data 0) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y)) (setf (display-boffset display) (index+ buffer-boffset 4))) ;; New Request (progn (put-items (4) (code +x-polypoint+) (data 0) ;; Relative-p false (length 4) (drawable drawable) (gcontext gcontext) (int16 x y)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 16))))))) (display-invoke-after-function display))) (defun draw-points (drawable gcontext points &optional relative-p) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p)) (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) ((sequence :format int16) points))) (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x1 y1 x2 y2) (type generalized-boolean relative-p)) (let ((display (drawable-display drawable))) (declare (type display display)) (when relative-p (incf x2 x1) (incf y2 y1)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x1 y1 x2 y2)) (setf (display-boffset display) (index+ buffer-boffset 8))) ;; New Request (progn (put-items (4) (code +x-polysegment+) (length 5) (drawable drawable) (gcontext gcontext) (int16 x1 y1 x2 y2)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p fill-p) (type (member :complex :non-convex :convex) shape)) (if fill-p (fill-polygon drawable gcontext points relative-p shape) (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext) ((data boolean) relative-p) (drawable drawable) (gcontext gcontext) ((sequence :format int16) points)))) ;; Internal function called from DRAW-LINES (defun fill-polygon (drawable gcontext points relative-p shape) ;; This is clever about appending to previous requests. Should it be? (declare (type drawable drawable) (type gcontext gcontext) (type sequence points) ;(repeat-seq (integer x) (integer y)) (type generalized-boolean relative-p) (type (member :complex :non-convex :convex) shape)) (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((member8 :complex :non-convex :convex) shape) (boolean relative-p) ((sequence :format int16) points))) (defun draw-segments (drawable gcontext segments) (declare (type drawable drawable) (type gcontext gcontext) ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2))) (type sequence segments)) (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) segments))) (defun draw-rectangle (drawable gcontext x y width height &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) request) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y) (card16 width height)) (setf (display-boffset display) (index+ buffer-boffset 8))) ;; New Request (progn (put-items (4) (code request) (length 5) (drawable drawable) (gcontext gcontext) (int16 x y) (card16 width height)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 20))))))) (display-invoke-after-function display))) (defun draw-rectangles (drawable gcontext rectangles &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) ;; (repeat-seq (integer x) (integer y) (integer width) (integer height))) (type sequence rectangles) (type generalized-boolean fill-p)) (with-buffer-request ((drawable-display drawable) (if fill-p +x-polyfillrectangle+ +x-polyrectangle+) :gc-force gcontext) (drawable drawable) (gcontext gcontext) ((sequence :format int16) rectangles))) (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p) ;; Should be clever about appending to existing buffered protocol request. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type card16 width height) (type angle angle1 angle2) (type generalized-boolean fill-p)) (let ((display (drawable-display drawable)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (declare (type display display) (type card16 request)) (with-display (display) (force-gcontext-changes-internal gcontext) (with-buffer-output (display :length +requestsize+) (let* ((last-request-byte (display-last-request display)) (current-boffset buffer-boffset)) ;; To append or not append, that is the question (if (and (not *inhibit-appending*) last-request-byte ;; Same request? (= (aref-card8 buffer-bbuf last-request-byte) request) (progn ;; Set buffer pointers to last request (set-buffer-offset last-request-byte) ;; same drawable and gcontext? (or (compare-request (4) (drawable drawable) (gcontext gcontext)) (progn ;; If failed, reset buffer pointers (set-buffer-offset current-boffset) nil)))) ;; Append request (progn ;; Set new request length (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte) -2))) (set-buffer-offset current-boffset) (put-items (0) ; Insert new point (int16 x y) (card16 width height) (angle angle1 angle2)) (setf (display-boffset display) (index+ buffer-boffset 12))) ;; New Request (progn (put-items (4) (code request) (length 6) (drawable drawable) (gcontext gcontext) (int16 x y) (card16 width height) (angle angle1 angle2)) (buffer-new-request-number display) (setf (buffer-last-request display) buffer-boffset) (setf (display-boffset display) (index+ buffer-boffset 24))))))) (display-invoke-after-function display))) (defun draw-arcs-list (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type list arcs) (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data (do ((arc arcs)) ((endp arc) (setf (buffer-boffset display) buffer-boffset)) ;; Make sure there's room (when (index>= buffer-boffset limit) (setf (buffer-boffset display) buffer-boffset) (buffer-flush display) (set-buffer-offset (buffer-boffset display))) (int16-put 0 (pop arc)) (int16-put 2 (pop arc)) (card16-put 4 (pop arc)) (card16-put 6 (pop arc)) (angle-put 8 (pop arc)) (angle-put 10 (pop arc)) (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs-vector (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type vector arcs) (type generalized-boolean fill-p)) (let* ((display (drawable-display drawable)) (limit (index- (buffer-size display) 12)) (length (length arcs)) (request (if fill-p +x-polyfillarc+ +x-polyarc+))) (with-buffer-request ((drawable-display drawable) request :gc-force gcontext) (drawable drawable) (gcontext gcontext) (progn (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words) (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data (do ((n 0 (index+ n 6)) (length (length arcs))) ((index>= n length) (setf (buffer-boffset display) buffer-boffset)) ;; Make sure there's room (when (index>= buffer-boffset limit) (setf (buffer-boffset display) buffer-boffset) (buffer-flush display) (set-buffer-offset (buffer-boffset display))) (int16-put 0 (aref arcs (index+ n 0))) (int16-put 2 (aref arcs (index+ n 1))) (card16-put 4 (aref arcs (index+ n 2))) (card16-put 6 (aref arcs (index+ n 3))) (angle-put 8 (aref arcs (index+ n 4))) (angle-put 10 (aref arcs (index+ n 5))) (set-buffer-offset (index+ buffer-boffset 12))))))) (defun draw-arcs (drawable gcontext arcs &optional fill-p) (declare (type drawable drawable) (type gcontext gcontext) (type sequence arcs) (type generalized-boolean fill-p)) (etypecase arcs (list (draw-arcs-list drawable gcontext arcs fill-p)) (vector (draw-arcs-vector drawable gcontext arcs fill-p)))) ;; The following image routines are bare minimum. It may be useful to define ;; some form of "image" object to hide representation details and format ;; conversions. It also may be useful to provide stream-oriented interfaces ;; for reading and writing the data. (defun put-raw-image (drawable gcontext data &key (start 0) (depth (required-arg depth)) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (left-pad 0) (format (required-arg format))) ;; Data must be a sequence of 8-bit quantities, already in the appropriate format ;; for transmission; the caller is responsible for all byte and bit swapping and ;; compaction. Start is the starting index in data; the end is computed from the ;; other arguments. (declare (type drawable drawable) (type gcontext gcontext) (type sequence data) ; Sequence of integers (type array-index start) (type card8 depth left-pad) ;; required (type int16 x y) ;; required (type card16 width height) ;; required (type (member :bitmap :xy-pixmap :z-pixmap) format)) (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) format) (drawable drawable) (gcontext gcontext) (card16 width height) (int16 x y) (card8 left-pad depth) (pad16 nil) ((sequence :format card8 :start start) data))) (defun get-raw-image (drawable &key data (start 0) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (plane-mask #xffffffff) (format (required-arg format)) (result-type '(vector card8))) ;; If data is given, it is modified in place (and returned), otherwise a new sequence ;; is created and returned, with a size computed from the other arguments and the ;; returned depth. The sequence is filled with 8-bit quantities, in transmission ;; format; the caller is responsible for any byte and bit swapping and compaction ;; required for further local use. (declare (type drawable drawable) (type (or null sequence) data) ;; sequence of integers (type int16 x y) ;; required (type card16 width height) ;; required (type array-index start) (type pixel plane-mask) (type (member :xy-pixmap :z-pixmap) format)) (declare (clx-values (clx-sequence integer) depth visual-info)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) (card16 width height) (card32 plane-mask)) (let ((depth (card8-get 1)) (length (* 4 (card32-get 4))) (visual (resource-id-get 8))) (values (sequence-get :result-type result-type :format card8 :length length :start start :data data :index +replysize+) depth (visual-info display visual)))))) cmucl-21a/src/clx/image.lisp000066400000000000000000003107501260377556400161170ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX Image functions ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: image.lisp,v 1.13 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defmacro with-image-data-buffer ((buffer size) &body body) (declare (indentation 0 4 1 1)) `(let ((.reply-buffer. (allocate-reply-buffer ,size))) (declare (type reply-buffer .reply-buffer.)) (unwind-protect (let ((,buffer (reply-ibuf8 .reply-buffer.))) (declare (type buffer-bytes ,buffer)) (with-vector (,buffer buffer-bytes) ,@body)) (deallocate-reply-buffer .reply-buffer.)))) (def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil)) ;; Public structure (width 0 :type card16 :read-only t) (height 0 :type card16 :read-only t) (depth 1 :type card8 :read-only t) (plist nil :type list)) ;; Image-Plist accessors: (defmacro image-name (image) `(getf (image-plist ,image) :name)) (defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot)) (defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot)) (defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask)) (defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask)) (defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask)) (defun print-image (image stream depth) (declare (type image image) (ignore depth)) (print-unreadable-object (image stream :type t) (when (image-name image) (write-string (string (image-name image)) stream) (write-string " " stream)) (prin1 (image-width image) stream) (write-string "x" stream) (prin1 (image-height image) stream) (write-string "x" stream) (prin1 (image-depth image) stream))) (defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)) (defconstant +empty-data-z+ '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)) (def-clx-class (image-x (:include image) (:copier nil) (:print-function print-image)) ;; Use this format for shoveling image data ;; Private structure. Accessors for these NOT exported. (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap)) (bytes-per-line 0 :type card16) (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean) ; Bit order (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-boolean) ; Byte order (data +empty-data-x+ :type (array card8 (*))) ; row-major (unit +image-unit+ :type (member 8 16 32)) ; Bitmap unit (pad +image-pad+ :type (member 8 16 32)) ; Scanline pad (left-pad 0 :type card8)) ; Left pad (def-clx-class (image-xy (:include image) (:copier nil) (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bitmap-list nil :type list)) ;; list of bitmaps (def-clx-class (image-z (:include image) (:copier nil) (:print-function print-image)) ;; Public structure ;; Use this format for image processing (bits-per-pixel 1 :type (member 1 4 8 16 24 32)) (pixarray +empty-data-z+ :type pixarray)) (defun create-image (&key width height depth (data (required-arg data)) plist name x-hot y-hot red-mask blue-mask green-mask bits-per-pixel format bytes-per-line (byte-lsb-first-p #+clx-little-endian t #-clx-little-endian nil) (bit-lsb-first-p #+clx-little-endian t #-clx-little-endian nil) unit pad left-pad) ;; Returns an image-x image-xy or image-z structure, depending on the ;; type of the :DATA parameter. (declare (type (or null card16) width height) ; Required (type (or null card8) depth) ; Defualts to 1 (type (or buffer-bytes ; Returns image-x list ; Returns image-xy pixarray) data) ; Returns image-z (type list plist) (type (or null stringable) name) (type (or null card16) x-hot y-hot) (type (or null pixel) red-mask blue-mask green-mask) (type (or null (member 1 4 8 16 24 32)) bits-per-pixel) ;; The following parameters are ignored for image-xy and image-z: (type (or null (member :bitmap :xy-pixmap :z-pixmap)) format) ; defaults to :z-pixmap (type (or null card16) bytes-per-line) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (type (or null (member 8 16 32)) unit pad) (type (or null card8) left-pad)) (declare (clx-values image)) (let ((image (etypecase data (buffer-bytes ; image-x (let ((data data)) (declare (type buffer-bytes data)) (unless depth (setq depth (or bits-per-pixel 1))) (unless format (setq format (if (= depth 1) :xy-pixmap :z-pixmap))) (unless bits-per-pixel (setq bits-per-pixel (cond ((eq format :xy-pixmap) 1) ((index> depth 24) 32) ((index> depth 16) 24) ((index> depth 8) 16) ((index> depth 4) 8) ((index> depth 1) 4) (t 1)))) (unless width (required-arg width)) (unless height (required-arg height)) (unless bytes-per-line (let* ((pad (or pad 8)) (bits-per-line (index* width bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))) (declare (type array-index pad bits-per-line padded-bits-per-line)) (setq bytes-per-line (index-ceiling padded-bits-per-line 8)))) (unless unit (setq unit +image-unit+)) (unless pad (setq pad (dolist (pad '(32 16 8)) (when (and (index<= pad +image-pad+) (zerop (index-mod (index* bytes-per-line 8) pad))) (return pad))))) (unless left-pad (setq left-pad 0)) (make-image-x :width width :height height :depth depth :plist plist :format format :data data :bits-per-pixel bits-per-pixel :bytes-per-line bytes-per-line :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad :left-pad left-pad))) (list ; image-xy (let ((data data)) (declare (type list data)) (unless depth (setq depth (length data))) (when data (unless width (setq width (array-dimension (car data) 1))) (unless height (setq height (array-dimension (car data) 0)))) (make-image-xy :width width :height height :plist plist :depth depth :bitmap-list data))) (pixarray ; image-z (let ((data data)) (declare (type pixarray data)) (unless width (setq width (array-dimension data 1))) (unless height (setq height (array-dimension data 0))) (unless bits-per-pixel (setq bits-per-pixel (etypecase data (pixarray-32 32) (pixarray-24 24) (pixarray-16 16) (pixarray-8 8) (pixarray-4 4) (pixarray-1 1))))) (unless depth (setq depth bits-per-pixel)) (make-image-z :width width :height height :depth depth :plist plist :bits-per-pixel bits-per-pixel :pixarray data))))) (declare (type image image)) (when name (setf (image-name image) name)) (when x-hot (setf (image-x-hot image) x-hot)) (when y-hot (setf (image-y-hot image) y-hot)) (when red-mask (setf (image-red-mask image) red-mask)) (when blue-mask (setf (image-blue-mask image) blue-mask)) (when green-mask (setf (image-green-mask image) green-mask)) image)) ;;;----------------------------------------------------------------------------- ;;; Swapping stuff (defun image-noswap (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (if (index= srcinc destinc) (buffer-replace dest src destoff (index+ destoff (index* srcinc (index1- height)) srclen) srcoff) (do* ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc)) (destend (index+ deststart srclen) (index+ deststart srclen))) ((index-zerop h)) (declare (type array-index srcstart deststart destend) (type card16 h)) (buffer-replace dest src deststart destend srcstart)))) (defun image-swap-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 2) 2)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 2) (if lsb-first-p (setf (aref dest (index1+ (index+ deststart length))) (the card8 (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index1+ (index+ srcstart length))))))) (do ((i length (index- i 2)) (srcidx srcstart (index+ srcidx 2)) (destidx deststart (index+ destidx 2))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src srcidx)))))))) (defun image-swap-three-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 3) 3)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 3) (when (index= (index- srclen length) 2) (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 1))))) (if lsb-first-p (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 2)))))) (do ((i length (index- i 3)) (srcidx srcstart (index+ srcidx 3)) (destidx deststart (index+ destidx 3))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src srcidx)))))))) (defun image-swap-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 3)) (the card8 (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 3)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 3)) (the card8 (aref src srcidx)))))))) (defun image-swap-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length 1)) (the card8 (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length)) (the card8 (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 3)) (the card8 (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 2)) (the card8 (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (the card8 (aref src (index+ srcidx 3)))) (setf (aref dest (index+ destidx 2)) (the card8 (aref src srcidx))) (setf (aref dest (index+ destidx 3)) (the card8 (aref src (index1+ srcidx))))))))) (defun image-swap-nibbles (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (let ((byte (aref src srcidx))) (declare (type card8 byte)) (dpb (the card4 (ldb (byte 4 0) byte)) (byte 4 4) (the card4 (ldb (byte 4 4) byte))))))))))) (defun image-swap-nibbles-left (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index= i 1) (setf (aref dest destidx) (the card8 (let ((byte1 (aref src srcidx))) (declare (type card8 byte1)) (dpb (the card4 (ldb (byte 4 0) byte1)) (byte 4 4) 0))))) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (the card8 (let ((byte1 (aref src srcidx)) (byte2 (aref src (index1+ srcidx)))) (declare (type card8 byte1 byte2)) (dpb (the card4 (ldb (byte 4 0) byte1)) (byte 4 4) (the card4 (ldb (byte 4 4) byte2))))))))))) (defconstant +image-byte-reverse+ '#.(coerce '#( 0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240 8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248 4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244 12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252 2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242 10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250 6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246 14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254 1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241 9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249 5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245 13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253 3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243 11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251 7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247 15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255) '(vector card8))) (defun image-swap-bits (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p) (ignore lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index srcstart deststart) (type card16 h)) (do ((i srclen (index1- i)) (srcidx srcstart (index1+ srcidx)) (destidx deststart (index1+ destidx))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-two-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 2) 2)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 2) (if lsb-first-p (setf (aref dest (index1+ (index+ deststart length))) (br (aref src (index+ srcstart length)))) (setf (aref dest (index+ deststart length)) (br (aref src (index1+ (index+ srcstart length))))))) (do ((i length (index- i 2)) (srcidx srcstart (index+ srcidx 2)) (destidx deststart (index+ destidx 2))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index1+ srcidx)))) (setf (aref dest (index1+ destidx)) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-four-bytes (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length)) (br (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 1)) (br (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 2)) (br (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 3)) (br (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index+ srcidx 3)))) (setf (aref dest (index1+ destidx)) (br (aref src (index+ srcidx 2)))) (setf (aref dest (index+ destidx 2)) (br (aref src (index1+ srcidx)))) (setf (aref dest (index+ destidx 3)) (br (aref src srcidx))))))))))) (defun image-swap-bits-and-words (src dest srcoff destoff srclen srcinc destinc height lsb-first-p) (declare (type buffer-bytes src dest) (type array-index srcoff destoff srclen srcinc destinc) (type card16 height) (type generalized-boolean lsb-first-p)) #.(declare-buffun) (with-vector (src buffer-bytes) (with-vector (dest buffer-bytes) (let ((byte-reverse +image-byte-reverse+)) (with-vector (byte-reverse (simple-array card8 (256))) (macrolet ((br (byte) `(the card8 (aref byte-reverse (the card8 ,byte))))) (do ((length (index* (index-ceiling srclen 4) 4)) (h height (index1- h)) (srcstart srcoff (index+ srcstart srcinc)) (deststart destoff (index+ deststart destinc))) ((index-zerop h)) (declare (type array-index length srcstart deststart) (type card16 h)) (when (and (index= h 1) (not (index= srclen length))) (index-decf length 4) (unless lsb-first-p (setf (aref dest (index+ deststart length 1)) (br (aref src (index+ srcstart length 3))))) (when (if lsb-first-p (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length)) (br (aref src (index+ srcstart length 2))))) (when (if (null lsb-first-p) (index= (index- srclen length) 3) (not (index-zerop (index-logand srclen 2)))) (setf (aref dest (index+ deststart length 3)) (br (aref src (index+ srcstart length 1))))) (when lsb-first-p (setf (aref dest (index+ deststart length 2)) (br (aref src (index+ srcstart length)))))) (do ((i length (index- i 4)) (srcidx srcstart (index+ srcidx 4)) (destidx deststart (index+ destidx 4))) ((index-zerop i)) (declare (type array-index i srcidx destidx)) (setf (aref dest destidx) (br (aref src (index+ srcidx 2)))) (setf (aref dest (index1+ destidx)) (br (aref src (index+ srcidx 3)))) (setf (aref dest (index+ destidx 2)) (br (aref src srcidx))) (setf (aref dest (index+ destidx 3)) (br (aref src (index1+ srcidx)))))))))))) ;;; The following table gives the bit ordering within bytes (when accessed ;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to ;;; 31, where bit 0 should be leftmost on the display. For a given byte ;;; labelled A-B, A is for the most significant bit of the byte, and B is ;;; for the least significant bit. ;;; ;;; legend: ;;; 1 scanline-unit = 8 ;;; 2 scanline-unit = 16 ;;; 4 scanline-unit = 32 ;;; M byte-order = MostSignificant ;;; L byte-order = LeastSignificant ;;; m bit-order = MostSignificant ;;; l bit-order = LeastSignificant ;;; ;;; ;;; format ordering ;;; ;;; 1Mm 00-07 08-15 16-23 24-31 ;;; 2Mm 00-07 08-15 16-23 24-31 ;;; 4Mm 00-07 08-15 16-23 24-31 ;;; 1Ml 07-00 15-08 23-16 31-24 ;;; 2Ml 15-08 07-00 31-24 23-16 ;;; 4Ml 31-24 23-16 15-08 07-00 ;;; 1Lm 00-07 08-15 16-23 24-31 ;;; 2Lm 08-15 00-07 24-31 16-23 ;;; 4Lm 24-31 16-23 08-15 00-07 ;;; 1Ll 07-00 15-08 23-16 31-24 ;;; 2Ll 07-00 15-08 23-16 31-24 ;;; 4Ll 07-00 15-08 23-16 31-24 ;;; ;;; ;;; The following table gives the required conversion between any two ;;; formats. It is based strictly on the table above. If you believe one, ;;; you should believe the other. ;;; ;;; legend: ;;; n no changes ;;; s reverse 8-bit units within 16-bit units ;;; l reverse 8-bit units within 32-bit units ;;; w reverse 16-bit units within 32-bit units ;;; r reverse bits within 8-bit units ;;; sr s+R ;;; lr l+R ;;; wr w+R (defconstant +image-swap-function+ '#.(make-array '(12 12) :initial-contents (let ((n 'image-noswap) (s 'image-swap-two-bytes) (l 'image-swap-four-bytes) (w 'image-swap-words) (r 'image-swap-bits) (sr 'image-swap-bits-and-two-bytes) (lr 'image-swap-bits-and-four-bytes) (wr 'image-swap-bits-and-words)) (list #| 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll |# (list #| 1Mm |# n n n r sr lr n s l r r r ) (list #| 2Mm |# n n n r sr lr n s l r r r ) (list #| 4Mm |# n n n r sr lr n s l r r r ) (list #| 1Ml |# r r r n s l r sr lr n n n ) (list #| 2Ml |# sr sr sr s n w sr r wr s s s ) (list #| 4Ml |# lr lr lr l w n lr wr r l l l ) (list #| 1Lm |# n n n r sr lr n s l r r r ) (list #| 2Lm |# s s s sr r wr s n w sr sr sr) (list #| 4Lm |# l l l lr wr r l w n lr lr lr) (list #| 1Ll |# r r r n s l r sr lr n n n ) (list #| 2Ll |# r r r n s l r sr lr n n n ) (list #| 4Ll |# r r r n s l r sr lr n n n ))))) ;;; Of course, the table above is a lie. We also need to factor in the ;;; order of the source data to cope with swapping half of a unit at the ;;; end of a scanline, since we are trying to avoid de-ref'ing off the ;;; end of the source. ;;; ;;; Defines whether the first half of a unit has the first half of the data (defconstant +image-swap-lsb-first-p+ '#.(make-array 12 :initial-contents (list t #| 1mm |# t #| 2mm |# t #| 4mm |# t #| 1ml |# nil #| 2ml |# nil #| 4ml |# t #| 1lm |# nil #| 2lm |# nil #| 4lm |# t #| 1ll |# t #| 2ll |# t #| 4ll |# ))) (defun image-swap-function (bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p) (clx-values function lsb-first-p)) (cond ((index= bits-per-pixel 1) (let ((from-index (index+ (ecase from-bitmap-unit (32 2) (16 1) (8 0)) (if from-bit-lsb-first-p 3 0) (if from-byte-lsb-first-p 6 0)))) (values (aref +image-swap-function+ from-index (index+ (ecase to-bitmap-unit (32 2) (16 1) (8 0)) (if to-bit-lsb-first-p 3 0) (if to-byte-lsb-first-p 6 0))) (aref +image-swap-lsb-first-p+ from-index)))) (t (values (if (if (index= bits-per-pixel 4) (eq from-bit-lsb-first-p to-bit-lsb-first-p) (eq from-byte-lsb-first-p to-byte-lsb-first-p)) 'image-noswap (ecase bits-per-pixel (4 'image-swap-nibbles) (8 'image-noswap) (16 'image-swap-two-bytes) (24 'image-swap-three-bytes) (32 'image-swap-four-bytes))) from-byte-lsb-first-p)))) ;;;----------------------------------------------------------------------------- ;;; GET-IMAGE (defun read-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 8)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-bits (the array-index (mod (the (integer #x-FFFF 0) (- x)) 8))) (right-bits (index-mod (index- width left-bits) 8)) (middle-bits (- width left-bits right-bits)) (middle-bytes (floor middle-bits 8))) ((index>= y height)) (declare (type array-index start y left-bits right-bits)) (declare (fixnum middle-bits middle-bytes)) (cond ((< middle-bits 0) (let ((byte (aref buffer-bbuf (index1- start))) (x left-bits)) (declare (type card8 byte) (type array-index x)) (when (index> right-bits 6) (setf (aref array y (index- x 1)) (read-image-load-byte 1 7 byte))) (when (and (index> left-bits 1) (index> right-bits 5)) (setf (aref array y (index- x 2)) (read-image-load-byte 1 6 byte))) (when (and (index> left-bits 2) (index> right-bits 4)) (setf (aref array y (index- x 3)) (read-image-load-byte 1 5 byte))) (when (and (index> left-bits 3) (index> right-bits 3)) (setf (aref array y (index- x 4)) (read-image-load-byte 1 4 byte))) (when (and (index> left-bits 4) (index> right-bits 2)) (setf (aref array y (index- x 5)) (read-image-load-byte 1 3 byte))) (when (and (index> left-bits 5) (index> right-bits 1)) (setf (aref array y (index- x 6)) (read-image-load-byte 1 2 byte))) (when (index> left-bits 6) (setf (aref array y (index- x 7)) (read-image-load-byte 1 1 byte))))) (t (unless (index-zerop left-bits) (let ((byte (aref buffer-bbuf (index1- start))) (x left-bits)) (declare (type card8 byte) (type array-index x)) (setf (aref array y (index- x 1)) (read-image-load-byte 1 7 byte)) (when (index> left-bits 1) (setf (aref array y (index- x 2)) (read-image-load-byte 1 6 byte)) (when (index> left-bits 2) (setf (aref array y (index- x 3)) (read-image-load-byte 1 5 byte)) (when (index> left-bits 3) (setf (aref array y (index- x 4)) (read-image-load-byte 1 4 byte)) (when (index> left-bits 4) (setf (aref array y (index- x 5)) (read-image-load-byte 1 3 byte)) (when (index> left-bits 5) (setf (aref array y (index- x 6)) (read-image-load-byte 1 2 byte)) (when (index> left-bits 6) (setf (aref array y (index- x 7)) (read-image-load-byte 1 1 byte)) )))))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x left-bits (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((byte (aref buffer-bbuf end)) (x (index+ left-bits middle-bits))) (declare (type card8 byte) (type array-index x)) (setf (aref array y (index+ x 0)) (read-image-load-byte 1 0 byte)) (when (index> right-bits 1) (setf (aref array y (index+ x 1)) (read-image-load-byte 1 1 byte)) (when (index> right-bits 2) (setf (aref array y (index+ x 2)) (read-image-load-byte 1 2 byte)) (when (index> right-bits 3) (setf (aref array y (index+ x 3)) (read-image-load-byte 1 3 byte)) (when (index> right-bits 4) (setf (aref array y (index+ x 4)) (read-image-load-byte 1 4 byte)) (when (index> right-bits 5) (setf (aref array y (index+ x 5)) (read-image-load-byte 1 5 byte)) (when (index> right-bits 6) (setf (aref array y (index+ x 6)) (read-image-load-byte 1 6 byte)) ))))))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref array y (index+ x 0)) (read-image-load-byte 1 0 byte)) (setf (aref array y (index+ x 1)) (read-image-load-byte 1 1 byte)) (setf (aref array y (index+ x 2)) (read-image-load-byte 1 2 byte)) (setf (aref array y (index+ x 3)) (read-image-load-byte 1 3 byte)) (setf (aref array y (index+ x 4)) (read-image-load-byte 1 4 byte)) (setf (aref array y (index+ x 5)) (read-image-load-byte 1 5 byte)) (setf (aref array y (index+ x 6)) (read-image-load-byte 1 6 byte)) (setf (aref array y (index+ x 7)) (read-image-load-byte 1 7 byte)))) ))))) (defun read-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index-ceiling x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y)) (left-nibbles (mod (the fixnum (- x)) 2)) (right-nibbles (index-mod (index- width left-nibbles) 2)) (middle-nibbles (index- width left-nibbles right-nibbles)) (middle-bytes (index-floor middle-nibbles 2))) ((index>= y height)) (declare (type array-index start y left-nibbles right-nibbles middle-nibbles middle-bytes)) (unless (index-zerop left-nibbles) (setf (aref array y 0) (read-image-load-byte 4 4 (aref buffer-bbuf (index1- start))))) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (x left-nibbles (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref array y (index+ left-nibbles middle-nibbles)) (read-image-load-byte 4 0 (aref buffer-bbuf end))))) (declare (type array-index end i x)) (let ((byte (aref buffer-bbuf i))) (declare (type card8 byte)) (setf (aref array y (index+ x 0)) (read-image-load-byte 4 0 byte)) (setf (aref array y (index+ x 1)) (read-image-load-byte 4 4 byte)))) ))) (defun read-pixarray-8 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-8 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) x) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start width)) (i start (index1+ i)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (the card8 (aref buffer-bbuf i))))))) (defun read-pixarray-16 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-16 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 2)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 2))) (i start (index+ i 2)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)))))))) (defun read-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 3)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)))))))) (defun read-pixarray-32 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-32 array) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((start (index+ index (index* y padded-bytes-per-line) (index* x 4)) (index+ start padded-bytes-per-line)) (y 0 (index1+ y))) ((index>= y height)) (declare (type array-index start y)) (do* ((end (index+ start (index* width 4))) (i start (index+ i 4)) (x 0 (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref array y x) (read-image-assemble-bytes (aref buffer-bbuf (index+ i 0)) (aref buffer-bbuf (index+ i 1)) (aref buffer-bbuf (index+ i 2)) (aref buffer-bbuf (index+ i 3)))))))) (defun read-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel read-pixarray-function from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type function read-pixarray-function) (type (member 8 16 32) from-unit to-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (if (eq image-swap-function 'image-noswap) (funcall read-pixarray-function bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) (funcall (symbol-function image-swap-function) bbuf buf (index+ boffset (index* y padded-bytes-per-line)) 0 (index-ceiling (index* (index+ x width) bits-per-pixel) 8) padded-bytes-per-line padded-bytes-per-line height image-swap-lsb-first-p) (funcall read-pixarray-function buf 0 pixarray x 0 width height padded-bytes-per-line bits-per-pixel))))) (defun read-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type array-index boffset padded-bytes-per-line) (type pixarray pixarray) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-read-pixarray bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (read-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel ( 1 #'read-pixarray-1 ) ( 4 #'read-pixarray-4 ) ( 8 #'read-pixarray-8 ) (16 #'read-pixarray-16) (24 #'read-pixarray-24) (32 #'read-pixarray-32)) unit byte-lsb-first-p bit-lsb-first-p +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+))) (defun read-xy-format-image-x (buffer-bbuf index length data width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p pad) (declare (type buffer-bytes buffer-bbuf) (type card16 width height) (type array-index index length padded-bytes-per-line padded-bytes-per-plane) (type image-depth depth) (type (member 8 16 32) unit pad) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-x)) (assert (index<= (index* depth padded-bytes-per-plane) length)) (let* ((bytes-per-line (index-ceiling width 8)) (data-length (index* padded-bytes-per-plane depth))) (declare (type array-index bytes-per-line data-length)) (cond (data (check-type data buffer-bytes) (assert (index>= (length data) data-length))) (t (setq data (make-array data-length :element-type 'card8)))) (do ((plane 0 (index1+ plane))) ((index>= plane depth)) (declare (type image-depth plane)) (image-noswap buffer-bbuf data (index+ index (index* plane padded-bytes-per-plane)) (index* plane padded-bytes-per-plane) bytes-per-line padded-bytes-per-line padded-bytes-per-line height byte-lsb-first-p)) (create-image :width width :height height :depth depth :data data :bits-per-pixel 1 :format :xy-pixmap :bytes-per-line padded-bytes-per-line :unit unit :pad pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun read-z-format-image-x (buffer-bbuf index length data width height depth padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type card16 width height) (type array-index index length padded-bytes-per-line) (type image-depth depth) (type (member 8 16 32) unit pad) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (type (member 1 4 8 16 24 32) bits-per-pixel) (clx-values image-x)) (assert (index<= (index* height padded-bytes-per-line) length)) (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8)) (data-length (index* padded-bytes-per-line height))) (declare (type array-index bytes-per-line data-length)) (cond (data (check-type data buffer-bytes) (assert (index>= (length data) data-length))) (t (setq data (make-array data-length :element-type 'card8)))) (image-noswap buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line padded-bytes-per-line height byte-lsb-first-p) (create-image :width width :height height :depth depth :data data :bits-per-pixel bits-per-pixel :format :z-pixmap :bytes-per-line padded-bytes-per-line :unit unit :pad pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun read-image-xy (bbuf index length data x y width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type card16 x y width height) (type array-index index length padded-bytes-per-line padded-bytes-per-plane) (type image-depth depth) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-xy)) (check-type data list) (multiple-value-bind (dimensions element-type) (if data (values (array-dimensions (first data)) (array-element-type (first data))) (values (list height (index* (index-ceiling width +image-pad+) +image-pad+)) 'pixarray-1-element-type)) (do* ((arrays data) (result nil) (limit (index+ length index)) (plane 0 (1+ plane)) (index index (index+ index padded-bytes-per-plane))) ((or (>= plane depth) (index> (index+ index padded-bytes-per-plane) limit)) (setq data (nreverse result) depth (length data))) (declare (type array-index limit index) (type image-depth plane) (type list arrays result)) (let ((array (or (pop arrays) (make-array dimensions :element-type element-type)))) (declare (type pixarray-1 array)) (push array result) (read-pixarray bbuf index array x y width height padded-bytes-per-line 1 unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth depth :data data))) (defun read-image-z (bbuf index length data x y width height depth padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type card16 x y width height) (type array-index index length padded-bytes-per-line) (type image-depth depth) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p) (clx-values image-z)) (assert (index<= (index* (index+ y height) padded-bytes-per-line) length)) (let* ((image-bits-per-line (index* width bits-per-pixel)) (image-pixels-per-line (index-ceiling (index* (index-ceiling image-bits-per-line +image-pad+) +image-pad+) bits-per-pixel))) (declare (type array-index image-bits-per-line image-pixels-per-line)) (unless data (setq data (make-array (list height image-pixels-per-line) :element-type (ecase bits-per-pixel (1 'pixarray-1-element-type) (4 'pixarray-4-element-type) (8 'pixarray-8-element-type) (16 'pixarray-16-element-type) (24 'pixarray-24-element-type) (32 'pixarray-32-element-type))))) (read-pixarray bbuf index data x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (create-image :width width :height height :depth depth :data data :bits-per-pixel bits-per-pixel))) (defun get-image (drawable &key data (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) plane-mask format result-type) (declare (type drawable drawable) (type (or buffer-bytes list pixarray) data) (type int16 x y) ;; required (type card16 width height) ;; required (type (or null pixel) plane-mask) (type (or null (member :xy-pixmap :z-pixmap)) format) (type (or null (member image-xy image-x image-z)) result-type) (clx-values image visual-info)) (unless result-type (setq result-type (ecase format (:xy-pixmap 'image-xy) (:z-pixmap 'image-z) ((nil) 'image-x)))) (unless format (setq format (case result-type (image-xy :xy-pixmap) ((image-z image-x) :z-pixmap)))) (unless (ecase result-type (image-xy (eq format :xy-pixmap)) (image-z (eq format :z-pixmap)) (image-x t)) (error "Result-type ~s is incompatable with format ~s" result-type format)) (unless plane-mask (setq plane-mask #xffffffff)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32)) (((data (member error :xy-pixmap :z-pixmap)) format) (drawable drawable) (int16 x y) (card16 width height) (card32 plane-mask)) (let* ((depth (card8-get 1)) (length (index* 4 (card32-get 4))) (visual-info (visual-info display (resource-id-get 8))) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type image-depth depth) (type array-index length) (type (or null visual-info) visual-info) (type bitmap-format bitmap-format) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (multiple-value-bind (pad bits-per-pixel) (ecase format (:xy-pixmap (values (bitmap-format-pad bitmap-format) 1)) (:z-pixmap (if (= depth 1) (values (bitmap-format-pad bitmap-format) 1) (let ((pixmap-format (find depth (display-pixmap-formats display) :key #'pixmap-format-depth))) (declare (type pixmap-format pixmap-format)) (values (pixmap-format-scanline-pad pixmap-format) (pixmap-format-bits-per-pixel pixmap-format)))))) (declare (type (member 8 16 32) pad) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (image (ecase result-type (image-x (ecase format (:xy-pixmap (read-xy-format-image-x buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p pad)) (:z-pixmap (read-z-format-image-x buffer-bbuf +replysize+ length data width height depth padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)))) (image-xy (read-image-xy buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line padded-bytes-per-plane unit byte-lsb-first-p bit-lsb-first-p)) (image-z (read-image-z buffer-bbuf +replysize+ length data 0 0 width height depth padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p))))) (declare (type image image) (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line)) (when visual-info (unless (zerop (visual-info-red-mask visual-info)) (setf (image-red-mask image) (visual-info-red-mask visual-info))) (unless (zerop (visual-info-green-mask visual-info)) (setf (image-green-mask image) (visual-info-green-mask visual-info))) (unless (zerop (visual-info-blue-mask visual-info)) (setf (image-blue-mask image) (visual-info-blue-mask visual-info)))) (values image visual-info))))))) ;;;----------------------------------------------------------------------------- ;;; PUT-IMAGE (defun write-pixarray-1 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-1 array) (type card16 x y width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-bits (index-mod width 8)) (middle-bits (index- width right-bits)) (middle-bytes (index-ceiling middle-bits 8)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-bits middle-bits middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x start-x (index+ x 8))) ((index>= i end) (unless (index-zerop right-bits) (let ((x (index+ start-x middle-bits))) (declare (type array-index x)) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ x 0)) (if (index> right-bits 1) (aref array y (index+ x 1)) 0) (if (index> right-bits 2) (aref array y (index+ x 2)) 0) (if (index> right-bits 3) (aref array y (index+ x 3)) 0) (if (index> right-bits 4) (aref array y (index+ x 4)) 0) (if (index> right-bits 5) (aref array y (index+ x 5)) 0) (if (index> right-bits 6) (aref array y (index+ x 6)) 0) 0))))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref array y (index+ x 0)) (aref array y (index+ x 1)) (aref array y (index+ x 2)) (aref array y (index+ x 3)) (aref array y (index+ x 4)) (aref array y (index+ x 5)) (aref array y (index+ x 6)) (aref array y (index+ x 7)))))))) (defun write-pixarray-4 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-4 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (right-nibbles (index-mod width 2)) (middle-nibbles (index- width right-nibbles)) (middle-bytes (index-ceiling middle-nibbles 2)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y right-nibbles middle-nibbles middle-bytes start)) (do* ((end (index+ start middle-bytes)) (i start (index1+ i)) (start-x x) (x start-x (index+ x 2))) ((index>= i end) (unless (index-zerop right-nibbles) (setf (aref buffer-bbuf end) (write-image-assemble-bytes (aref array y (index+ start-x middle-nibbles)) 0)))) (declare (type array-index end i start-x x)) (setf (aref buffer-bbuf i) (write-image-assemble-bytes (aref array y (index+ x 0)) (aref array y (index+ x 1)))))))) (defun write-pixarray-8 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-8 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start width)) (i start (index1+ i)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (setf (aref buffer-bbuf i) (the card8 (aref array y x))))))) (defun write-pixarray-16 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-16 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 2))) (i start (index+ i 2)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-16-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 16)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 16))))))) (defun write-pixarray-24 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-24 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index y start)) (do* ((end (index+ start (index* width 3))) (i start (index+ i 3)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-24-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 24)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 24)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 24))))))) (defun write-pixarray-32 (buffer-bbuf index array x y width height padded-bytes-per-line bits-per-pixel) (declare (type buffer-bytes buffer-bbuf) (type pixarray-32 array) (type int16 x y) (type card16 width height) (type array-index index padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (ignore bits-per-pixel)) #.(declare-buffun) (with-vector (buffer-bbuf buffer-bytes) (do* ((h 0 (index1+ h)) (y y (index1+ y)) (start index (index+ start padded-bytes-per-line))) ((index>= h height)) (declare (type array-index h y start)) (do* ((end (index+ start (index* width 4))) (i start (index+ i 4)) (x x (index1+ x))) ((index>= i end)) (declare (type array-index end i x)) (let ((pixel (aref array y x))) (declare (type pixarray-32-element-type pixel)) (setf (aref buffer-bbuf (index+ i 0)) (write-image-load-byte 0 pixel 32)) (setf (aref buffer-bbuf (index+ i 1)) (write-image-load-byte 8 pixel 32)) (setf (aref buffer-bbuf (index+ i 2)) (write-image-load-byte 16 pixel 32)) (setf (aref buffer-bbuf (index+ i 3)) (write-image-load-byte 24 pixel 32))))))) (defun write-pixarray-internal (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel write-pixarray-function from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type function write-pixarray-function) (type (member 8 16 32) from-unit to-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-unit from-byte-lsb-first-p from-bit-lsb-first-p to-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (if (eq image-swap-function 'image-noswap) (funcall write-pixarray-function bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel) (with-image-data-buffer (buf (index* height padded-bytes-per-line)) (funcall write-pixarray-function buf 0 pixarray x y width height padded-bytes-per-line bits-per-pixel) (funcall (symbol-function image-swap-function) buf bbuf 0 boffset (index-ceiling (index* width bits-per-pixel) 8) padded-bytes-per-line padded-bytes-per-line height image-swap-lsb-first-p))))) (defun write-pixarray (bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (declare (type buffer-bytes bbuf) (type pixarray pixarray) (type card16 x y width height) (type array-index boffset padded-bytes-per-line) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (unless (fast-write-pixarray bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (write-pixarray-internal bbuf boffset pixarray x y width height padded-bytes-per-line bits-per-pixel (ecase bits-per-pixel ( 1 #'write-pixarray-1 ) ( 4 #'write-pixarray-4 ) ( 8 #'write-pixarray-8 ) (16 #'write-pixarray-16) (24 #'write-pixarray-24) (32 #'write-pixarray-32)) +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+ unit byte-lsb-first-p bit-lsb-first-p))) (defun write-xy-format-image-x-data (data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) (type array-index data-start obuf-start from-padded-bytes-per-line to-padded-bytes-per-line) (type card16 x y width height) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (assert (index-zerop (index-mod x 8))) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function 1 from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (let ((x-mod-unit (index-mod x from-bitmap-unit))) (declare (type card16 x-mod-unit)) (if (and (index-plusp x-mod-unit) (not (eq from-byte-lsb-first-p from-bit-lsb-first-p))) (let* ((temp-width (index+ width x-mod-unit)) (temp-bytes-per-line (index-ceiling temp-width 8)) (temp-padded-bits-per-line (index* (index-ceiling temp-width from-bitmap-unit) from-bitmap-unit)) (temp-padded-bytes-per-line (index-ceiling temp-padded-bits-per-line 8))) (declare (type card16 temp-width temp-bytes-per-line temp-padded-bits-per-line temp-padded-bytes-per-line)) (with-image-data-buffer (buf (index* height temp-padded-bytes-per-line)) (funcall (symbol-function image-swap-function) data buf (index+ data-start (index* y from-padded-bytes-per-line) (index-floor (index- x x-mod-unit) 8)) 0 temp-bytes-per-line from-padded-bytes-per-line temp-padded-bytes-per-line height image-swap-lsb-first-p) (write-xy-format-image-x-data buf obuf 0 obuf-start x-mod-unit 0 width height temp-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))) (funcall (symbol-function image-swap-function) data obuf (index+ data-start (index* y from-padded-bytes-per-line) (index-floor x 8)) obuf-start (index-ceiling width 8) from-padded-bytes-per-line to-padded-bytes-per-line height image-swap-lsb-first-p))))) (defun write-xy-format-image-x (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-x image) (type int16 src-x src-y) (type card16 width height) (type array-index padded-bytes-per-line) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dotimes (plane (image-depth image)) (let ((data-start (index* (index* plane (image-height image)) (image-x-bytes-per-line image))) (src-y src-y) (height height)) (declare (type int16 src-y) (type card16 height)) (loop (when (index-zerop height) (return)) (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-xy-format-image-x-data (image-x-data image) (buffer-obuf8 display) data-start (buffer-boffset display) src-x src-y width nlines (image-x-bytes-per-line image) padded-bytes-per-line (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))))) (defun write-z-format-image-x-data (data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type buffer-bytes data obuf) (type array-index data-start obuf-start from-padded-bytes-per-line to-padded-bytes-per-line) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type (member 8 16 32) from-bitmap-unit to-bitmap-unit) (type generalized-boolean from-byte-lsb-first-p from-bit-lsb-first-p to-byte-lsb-first-p to-bit-lsb-first-p)) (if (index= bits-per-pixel 1) (write-xy-format-image-x-data data obuf data-start obuf-start x y width height from-padded-bytes-per-line to-padded-bytes-per-line from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (let ((srcoff (index+ data-start (index* y from-padded-bytes-per-line) (index-floor (index* x bits-per-pixel) 8))) (srclen (index-ceiling (index* width bits-per-pixel) 8))) (declare (type array-index srcoff srclen)) (if (and (index= bits-per-pixel 4) (index-oddp x)) (with-image-data-buffer (buf (index* height to-padded-bytes-per-line)) (image-swap-nibbles-left data buf srcoff 0 srclen from-padded-bytes-per-line to-padded-bytes-per-line height nil) (write-z-format-image-x-data buf obuf 0 obuf-start 0 0 width height to-padded-bytes-per-line to-padded-bytes-per-line bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (funcall (symbol-function image-swap-function) data obuf srcoff obuf-start srclen from-padded-bytes-per-line to-padded-bytes-per-line height image-swap-lsb-first-p)))))) (defun write-z-format-image-x (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-x image) (type int16 src-x src-y) (type card16 width height) (type array-index padded-bytes-per-line) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (when (index-zerop height) (return)) (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-z-format-image-x-data (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display) src-x src-y width nlines (image-x-bytes-per-line image) padded-bytes-per-line (image-x-bits-per-pixel image) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) (defun write-image-xy (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-xy image) (type array-index padded-bytes-per-line) (type int16 src-x src-y) (type card16 width height) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (dolist (bitmap (image-xy-bitmap-list image)) (declare (type pixarray-1 bitmap)) (let ((src-y src-y) (height height)) (declare (type int16 src-y) (type card16 height)) (loop (let ((nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type array-index nlines)) (when (index-plusp nlines) (write-pixarray (buffer-obuf8 display) (buffer-boffset display) bitmap src-x src-y width nlines padded-bytes-per-line 1 unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))))) (defun write-image-z (display image src-x src-y width height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p) (declare (type display display) (type image-z image) (type array-index padded-bytes-per-line) (type int16 src-x src-y) (type card16 width height) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (loop (let ((bits-per-pixel (image-z-bits-per-pixel image)) (nlines (index-min (index-floor (index- (buffer-size display) (buffer-boffset display)) padded-bytes-per-line) height))) (declare (type (member 1 4 8 16 24 32) bits-per-pixel) (type array-index nlines)) (when (index-plusp nlines) (write-pixarray (buffer-obuf8 display) (buffer-boffset display) (image-z-pixarray image) src-x src-y width nlines padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p) (index-incf (buffer-boffset display) (index* nlines padded-bytes-per-line)) (index-incf src-y nlines) (when (index-zerop (index-decf height nlines)) (return)))) (buffer-flush display))) ;;; Note: The only difference between a format of :bitmap and :xy-pixmap ;;; of depth 1 is that when sending a :bitmap format the foreground ;;; and background in the gcontext are used. (defun put-image (drawable gcontext image &key (src-x 0) (src-y 0) ;Position within image (x (required-arg x)) ;Position within drawable (y (required-arg y)) width height bitmap-p) ;; Copy an image into a drawable. ;; WIDTH and HEIGHT default from IMAGE. ;; When BITMAP-P, force format to be :bitmap when depth=1. ;; This causes gcontext to supply foreground & background pixels. (declare (type drawable drawable) (type gcontext gcontext) (type image image) (type int16 x y) ;; required (type int16 src-x src-y) (type (or null card16) width height) (type generalized-boolean bitmap-p)) (let* ((format (etypecase image (image-x (image-x-format (the image-x image))) (image-xy :xy-pixmap) (image-z :z-pixmap))) (src-x (if (image-x-p image) (index+ src-x (image-x-left-pad (the image-x image))) src-x)) (image-width (image-width image)) (image-height (image-height image)) (width (min (or width image-width) (index- image-width src-x))) (height (min (or height image-height) (index- image-height src-y))) (depth (image-depth image)) (display (drawable-display drawable)) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (declare (type (member :bitmap :xy-pixmap :z-pixmap) format) (type fixnum src-x image-width image-height width height) (type image-depth depth) (type display display) (type bitmap-format bitmap-format) (type (member 8 16 32) unit) (type generalized-boolean byte-lsb-first-p bit-lsb-first-p)) (when (and bitmap-p (not (index= depth 1))) (error "Bitmaps must have depth 1")) (unless (<= 0 src-x (index1- (image-width image))) (error "src-x not inside image")) (unless (<= 0 src-y (index1- (image-height image))) (error "src-y not inside image")) (when (and (index> width 0) (index> height 0)) (multiple-value-bind (pad bits-per-pixel) (ecase format ((:bitmap :xy-pixmap) (values (bitmap-format-pad bitmap-format) 1)) (:z-pixmap (if (= depth 1) (values (bitmap-format-pad bitmap-format) 1) (let ((pixmap-format (find depth (display-pixmap-formats display) :key #'pixmap-format-depth))) (declare (type (or null pixmap-format) pixmap-format)) (if (null pixmap-format) (error "The depth of the image ~s does not match any server pixmap format." image)) (if (not (= (etypecase image (image-z (image-z-bits-per-pixel image)) (image-x (image-x-bits-per-pixel image))) (pixmap-format-bits-per-pixel pixmap-format))) ;; We could try to use the "/* XXX slow, but works */" ;; code in XPutImage from X11R4 here. However, that ;; would require considerable support code ;; (see XImUtil.c, etc). (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image)) (values (pixmap-format-scanline-pad pixmap-format) (pixmap-format-bits-per-pixel pixmap-format)))))) (declare (type (member 8 16 32) pad) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((left-pad (if (or (eq format :xy-pixmap) (= depth 1)) (index-mod src-x (index-min pad +image-pad+)) 0)) (left-padded-src-x (index- src-x left-pad)) (left-padded-width (index+ width left-pad)) (bits-per-line (index* left-padded-width bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (request-bytes-per-line (ecase format ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth)) (:z-pixmap padded-bytes-per-line))) (max-bytes-per-request (index* (index- (display-max-request-length display) 6) 4)) (max-request-height (floor max-bytes-per-request request-bytes-per-line))) (declare (type card8 left-pad) (type int16 left-padded-src-x) (type card16 left-padded-width) (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line request-bytes-per-line max-bytes-per-request max-request-height)) ;; Be sure that a scanline can fit in a request (when (index-zerop max-request-height) (error "Can't even fit one image scanline in a request")) ;; Be sure a scanline can fit in a buffer (buffer-ensure-size display padded-bytes-per-line) ;; Send the image in multiple requests to avoid exceeding the ;; request limit (do* ((request-src-y src-y (index+ request-src-y request-height)) (request-y y (index+ request-y request-height)) (height-remaining height (the fixnum (- height-remaining request-height))) (request-height (index-min height-remaining max-request-height) (index-min height-remaining max-request-height))) ((<= height-remaining 0)) (declare (type array-index request-src-y request-height) (fixnum height-remaining)) (let* ((request-bytes (index* request-bytes-per-line request-height)) (request-words (index-ceiling request-bytes 4)) (request-length (index+ request-words 6))) (declare (type array-index request-bytes) (type card16 request-words request-length)) (with-buffer-request (display +x-putimage+ :gc-force gcontext) ((data (member :bitmap :xy-pixmap :z-pixmap)) (cond ((or (eq format :bitmap) bitmap-p) :bitmap) ((plusp left-pad) :xy-pixmap) (t format))) (drawable drawable) (gcontext gcontext) (card16 width request-height) (int16 x request-y) (card8 left-pad depth) (pad16 nil) (progn (length-put 2 request-length) (setf (buffer-boffset display) (advance-buffer-offset 24)) (etypecase image (image-x (ecase (image-x-format (the image-x image)) ((:bitmap :xy-pixmap) (write-xy-format-image-x display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) (:z-pixmap (write-z-format-image-x display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)))) (image-xy (write-image-xy display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) (image-z (write-image-z display image left-padded-src-x request-src-y left-padded-width request-height padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p))) ;; Be sure the request is padded to a multiple of 4 bytes (buffer-pad-request display (index- (index* request-words 4) request-bytes)) ))))))))) ;;;----------------------------------------------------------------------------- ;;; COPY-IMAGE (defun xy-format-image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) (left-pad (index-mod padded-x 8)) (x (index- padded-x left-pad)) (unit (image-x-unit image)) (byte-lsb-first-p (image-x-byte-lsb-first-p image)) (bit-lsb-first-p (image-x-bit-lsb-first-p image)) (pad (image-x-pad image)) (padded-width (index* (index-ceiling (index+ width left-pad) pad) pad)) (padded-bytes-per-line (index-ceiling padded-width 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (length (index* padded-bytes-per-plane (image-depth image))) (obuf (make-array length :element-type 'card8))) (declare (type card16 x) (type card8 left-pad) (type (member 8 16 32) unit pad) (type array-index padded-width padded-bytes-per-line padded-bytes-per-plane length) (type buffer-bytes obuf)) (dotimes (plane (image-depth image)) (let ((data-start (index* (image-x-bytes-per-line image) (image-height image) plane)) (obuf-start (index* padded-bytes-per-plane plane))) (declare (type array-index data-start obuf-start)) (write-xy-format-image-x-data (image-x-data image) obuf data-start obuf-start x y width height (image-x-bytes-per-line image) padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p unit byte-lsb-first-p bit-lsb-first-p))) (create-image :width width :height height :depth (image-depth image) :data obuf :format (image-x-format image) :bits-per-pixel 1 :bytes-per-line padded-bytes-per-line :unit unit :pad pad :left-pad left-pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun z-format-image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-x (index+ x (image-x-left-pad image))) (left-pad (if (index= (image-depth image) 1) (index-mod padded-x 8) 0)) (x (index- padded-x left-pad)) (bits-per-pixel (image-x-bits-per-pixel image)) (unit (image-x-unit image)) (byte-lsb-first-p (image-x-byte-lsb-first-p image)) (bit-lsb-first-p (image-x-bit-lsb-first-p image)) (pad (image-x-pad image)) (bits-per-line (index* (index+ width left-pad) bits-per-pixel)) (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (length (index* padded-bytes-per-plane (image-depth image))) (obuf (make-array length :element-type 'card8))) (declare (type card16 x) (type card8 left-pad) (type (member 8 16 32) unit pad) (type array-index bits-per-pixel padded-bytes-per-line padded-bytes-per-plane length) (type buffer-bytes obuf)) (write-z-format-image-x-data (image-x-data image) obuf 0 0 x y width height (image-x-bytes-per-line image) padded-bytes-per-line bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p unit byte-lsb-first-p bit-lsb-first-p) (create-image :width width :height height :depth (image-depth image) :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel :bytes-per-line padded-bytes-per-line :unit unit :pad pad :left-pad left-pad :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p))) (defun image-x->image-x (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-x)) (ecase (image-x-format image) ((:bitmap :xy-pixmap) (xy-format-image-x->image-x image x y width height)) (:z-pixmap (z-format-image-x->image-x image x y width height)))) (defun image-x->image-xy (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-xy)) (unless (or (eq (image-x-format image) :bitmap) (eq (image-x-format image) :xy-pixmap) (and (eq (image-x-format image) :z-pixmap) (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" (image-x-format image) :xy-pixmap)) (read-image-xy (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height (image-depth image) (image-x-bytes-per-line image) (index* (image-x-bytes-per-line image) (image-height image)) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image))) (defun image-x->image-z (image x y width height) (declare (type image-x image) (type card16 x y width height) (clx-values image-z)) (unless (or (eq (image-x-format image) :z-pixmap) (eq (image-x-format image) :bitmap) (and (eq (image-x-format image) :xy-pixmap) (index= (image-depth image) 1))) (error "Format conversion from ~S to ~S not supported" (image-x-format image) :z-pixmap)) (read-image-z (image-x-data image) 0 (length (image-x-data image)) nil (index+ x (image-x-left-pad image)) y width height (image-depth image) (image-x-bytes-per-line image) (image-x-bits-per-pixel image) (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image))) (defun copy-pixarray (array x y width height bits-per-pixel) (declare (type pixarray array) (type card16 x y width height) (type (member 1 4 8 16 24 32) bits-per-pixel)) (let* ((bits-per-line (index* bits-per-pixel width)) (padded-bits-per-line (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-width (index-ceiling padded-bits-per-line bits-per-pixel)) (copy (make-array (list height padded-width) :element-type (array-element-type array)))) (declare (type array-index bits-per-line padded-bits-per-line padded-width) (type pixarray copy)) #.(declare-buffun) (unless (fast-copy-pixarray array copy x y width height bits-per-pixel) (macrolet ((copy (array-type element-type) `(let ((array array) (copy copy)) (declare (type ,array-type array copy)) (do* ((dst-y 0 (index1+ dst-y)) (src-y y (index1+ src-y))) ((index>= dst-y height)) (declare (type card16 dst-y src-y)) (do* ((dst-x 0 (index1+ dst-x)) (src-x x (index1+ src-x))) ((index>= dst-x width)) (declare (type card16 dst-x src-x)) (setf (aref copy dst-y dst-x) (the ,element-type (aref array src-y src-x)))))))) (ecase bits-per-pixel (1 (copy pixarray-1 pixarray-1-element-type)) (4 (copy pixarray-4 pixarray-4-element-type)) (8 (copy pixarray-8 pixarray-8-element-type)) (16 (copy pixarray-16 pixarray-16-element-type)) (24 (copy pixarray-24 pixarray-24-element-type)) (32 (copy pixarray-32 pixarray-32-element-type))))) copy)) (defun image-xy->image-x (image x y width height) (declare (type image-xy image) (type card16 x y width height) (clx-values image-x)) (let* ((padded-bits-per-line (index* (index-ceiling width +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (padded-bytes-per-plane (index* padded-bytes-per-line height)) (bytes-total (index* padded-bytes-per-plane (image-depth image))) (data (make-array bytes-total :element-type 'card8))) (declare (type array-index padded-bits-per-line padded-bytes-per-line padded-bytes-per-plane bytes-total) (type buffer-bytes data)) (let ((index 0)) (declare (type array-index index)) (dolist (bitmap (image-xy-bitmap-list image)) (declare (type pixarray-1 bitmap)) (write-pixarray data index bitmap x y width height padded-bytes-per-line 1 +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (index-incf index padded-bytes-per-plane))) (create-image :width width :height height :depth (image-depth image) :data data :format :xy-pixmap :bits-per-pixel 1 :bytes-per-line padded-bytes-per-line :unit +image-unit+ :pad +image-pad+ :byte-lsb-first-p +image-byte-lsb-first-p+ :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-xy->image-xy (image x y width height) (declare (type image-xy image) (type card16 x y width height) (clx-values image-xy)) (create-image :width width :height height :depth (image-depth image) :data (mapcar #'(lambda (array) (declare (type pixarray-1 array)) (copy-pixarray array x y width height 1)) (image-xy-bitmap-list image)))) (defun image-xy->image-z (image x y width height) (declare (type image-xy image) (type card16 x y width height) (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" :xy-pixmap :z-pixmap)) (defun image-z->image-x (image x y width height) (declare (type image-z image) (type card16 x y width height) (clx-values image-x)) (let* ((bits-per-line (index* width (image-z-bits-per-pixel image))) (padded-bits-per-line (index* (index-ceiling bits-per-line +image-pad+) +image-pad+)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (bytes-total (index* padded-bytes-per-line height (image-depth image))) (data (make-array bytes-total :element-type 'card8)) (bits-per-pixel (image-z-bits-per-pixel image))) (declare (type array-index bits-per-line padded-bits-per-line padded-bytes-per-line bytes-total) (type buffer-bytes data) (type (member 1 4 8 16 24 32) bits-per-pixel)) (write-pixarray data 0 (image-z-pixarray image) x y width height padded-bytes-per-line (image-z-bits-per-pixel image) +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+) (create-image :width width :height height :depth (image-depth image) :data data :format :z-pixmap :bits-per-pixel bits-per-pixel :bytes-per-line padded-bytes-per-line :unit +image-unit+ :pad +image-pad+ :byte-lsb-first-p +image-byte-lsb-first-p+ :bit-lsb-first-p +image-bit-lsb-first-p+))) (defun image-z->image-xy (image x y width height) (declare (type image-z image) (type card16 x y width height) (ignore image x y width height)) (error "Format conversion from ~S to ~S not supported" :z-pixmap :xy-pixmap)) (defun image-z->image-z (image x y width height) (declare (type image-z image) (type card16 x y width height) (clx-values image-z)) (create-image :width width :height height :depth (image-depth image) :data (copy-pixarray (image-z-pixarray image) x y width height (image-z-bits-per-pixel image)))) (defun copy-image (image &key (x 0) (y 0) width height result-type) ;; Copy with optional sub-imaging and format conversion. ;; result-type defaults to (type-of image) (declare (type image image) (type card16 x y) (type (or null card16) width height) ;; Default from image (type (or null (member image-x image-xy image-z)) result-type)) (declare (clx-values image)) (let* ((image-width (image-width image)) (image-height (image-height image)) (width (or width image-width)) (height (or height image-height))) (declare (type card16 image-width image-height width height)) (unless (<= 0 x (the fixnum (1- image-width))) (error "x not inside image")) (unless (<= 0 y (the fixnum (1- image-height))) (error "y not inside image")) (setq width (index-min width (max (the fixnum (- image-width x)) 0))) (setq height (index-min height (max (the fixnum (- image-height y)) 0))) (let ((copy (etypecase image (image-x (ecase result-type ((nil image-x) (image-x->image-x image x y width height)) (image-xy (image-x->image-xy image x y width height)) (image-z (image-x->image-z image x y width height)))) (image-xy (ecase result-type (image-x (image-xy->image-x image x y width height)) ((nil image-xy) (image-xy->image-xy image x y width height)) (image-z (image-xy->image-z image x y width height)))) (image-z (ecase result-type (image-x (image-z->image-x image x y width height)) (image-xy (image-z->image-xy image x y width height)) ((nil image-z) (image-z->image-z image x y width height))))))) (declare (type image copy)) (setf (image-plist copy) (copy-list (image-plist image))) (when (and (image-x-hot image) (not (index-zerop x))) (setf (image-x-hot copy) (index- (image-x-hot image) x))) (when (and (image-y-hot image) (not (index-zerop y))) (setf (image-y-hot copy) (index- (image-y-hot image) y))) copy))) ;;;----------------------------------------------------------------------------- ;;; Image I/O functions (defun read-bitmap-file (pathname) ;; Creates an image from a C include file in standard X11 format (declare (type (or pathname string stream) pathname)) (declare (clx-values image)) (with-open-file (fstream pathname :direction :input) (let ((line "") (properties nil) (name nil) (name-end nil)) (declare (type string line) (type stringable name) (type list properties)) ;; Get properties (loop (setq line (read-line fstream)) (unless (char= (aref line 0) #\#) (return)) (flet ((read-keyword (line start end) (kintern (substitute #\- #\_ (#-excl string-upcase #+excl correct-case (subseq line start end)) :test #'char=)))) (when (null name) (setq name-end (position #\_ line :test #'char= :from-end t) name (read-keyword line 8 name-end)) (unless (eq name :image) (setf (getf properties :name) name))) (let* ((ind-start (index1+ name-end)) (ind-end (position #\Space line :test #'char= :start ind-start)) (ind (read-keyword line ind-start ind-end)) (val-start (index1+ ind-end)) (val (parse-integer line :start val-start))) (setf (getf properties ind) val)))) ;; Calculate sizes (multiple-value-bind (width height depth left-pad) (flet ((extract-property (ind &rest default) (prog1 (apply #'getf properties ind default) (remf properties ind)))) (values (extract-property :width) (extract-property :height) (extract-property :depth 1) (extract-property :left-pad 0))) (declare (type (or null card16) width height) (type image-depth depth) (type card8 left-pad)) (unless (and width height) (error "Not a BITMAP file")) (let* ((bits-per-pixel (cond ((index> depth 24) 32) ((index> depth 16) 24) ((index> depth 8) 16) ((index> depth 4) 8) ((index> depth 1) 4) (t 1))) (bits-per-line (index* width bits-per-pixel)) (bytes-per-line (index-ceiling bits-per-line 8)) (padded-bits-per-line (index* (index-ceiling bits-per-line 32) 32)) (padded-bytes-per-line (index-ceiling padded-bits-per-line 8)) (data (make-array (* padded-bytes-per-line height) :element-type 'card8)) (line-base 0) (byte 0)) (declare (type array-index bits-per-line bytes-per-line padded-bits-per-line padded-bytes-per-line line-base byte) (type buffer-bytes data)) (with-vector (data buffer-bytes) (flet ((parse-hex (char) (second (assoc char '((#\0 0) (#\1 1) (#\2 2) (#\3 3) (#\4 4) (#\5 5) (#\6 6) (#\7 7) (#\8 8) (#\9 9) (#\a 10) (#\b 11) (#\c 12) (#\d 13) (#\e 14) (#\f 15)) :test #'char-equal)))) (declare (inline parse-hex)) ;; Read data ;; Note: using read-line instead of read-char would be 20% faster, ;; but would cons a lot of garbage... (dotimes (i height) (dotimes (j bytes-per-line) (loop (when (eql (read-char fstream) #\x) (return))) (setf (aref data (index+ line-base byte)) (index+ (index-ash (parse-hex (read-char fstream)) 4) (parse-hex (read-char fstream)))) (incf byte)) (setq byte 0 line-base (index+ line-base padded-bytes-per-line))))) ;; Compensate for left-pad in width and x-hot (index-decf width left-pad) (when (and (getf properties :x-hot) (plusp (getf properties :x-hot))) (index-decf (getf properties :x-hot) left-pad)) (create-image :width width :height height :depth depth :bits-per-pixel bits-per-pixel :data data :plist properties :format :z-pixmap :bytes-per-line padded-bytes-per-line :unit 32 :pad 32 :left-pad left-pad :byte-lsb-first-p t :bit-lsb-first-p t)))))) (defun write-bitmap-file (pathname image &optional name) ;; Writes an image to a C include file in standard X11 format ;; NAME argument used for variable prefixes. Defaults to "image" (declare (type (or pathname string stream) pathname) (type image image) (type (or null stringable) name)) (unless (typep image 'image-x) (setq image (copy-image image :result-type 'image-x))) (let* ((plist (image-plist image)) (name (or name (image-name image) 'image)) (left-pad (image-x-left-pad image)) (width (index+ (image-width image) left-pad)) (height (image-height image)) (depth (if (eq (image-x-format image) :z-pixmap) (image-depth image) 1)) (bits-per-pixel (image-x-bits-per-pixel image)) (bits-per-line (index* width bits-per-pixel)) (bytes-per-line (index-ceiling bits-per-line 8)) (last (index* bytes-per-line height)) (count 0)) (declare (type list plist) (type stringable name) (type card8 left-pad) (type card16 width height) (type (member 1 4 8 16 24 32) bits-per-pixel) (type image-depth depth) (type array-index bits-per-line bytes-per-line count last)) ;; Move x-hot by left-pad, if there is an x-hot, so image readers that ;; don't know about left pad get the hot spot in the right place. We have ;; already increased width by left-pad. (when (getf plist :x-hot) (setq plist (copy-list plist)) (index-incf (getf plist :x-hot) left-pad)) (with-image-data-buffer (data last) (multiple-value-bind (image-swap-function image-swap-lsb-first-p) (image-swap-function bits-per-pixel (image-x-unit image) (image-x-byte-lsb-first-p image) (image-x-bit-lsb-first-p image) 32 t t) (declare (type symbol image-swap-function) (type generalized-boolean image-swap-lsb-first-p)) (funcall (symbol-function image-swap-function) (image-x-data image) data 0 0 bytes-per-line (image-x-bytes-per-line image) bytes-per-line height image-swap-lsb-first-p)) (with-vector (data buffer-bytes) (setq name (string-downcase (string name))) (with-open-file (fstream pathname :direction :output) (format fstream "#define ~a_width ~d~%" name width) (format fstream "#define ~a_height ~d~%" name height) (unless (= depth 1) (format fstream "#define ~a_depth ~d~%" name depth)) (unless (zerop left-pad) (format fstream "#define ~a_left_pad ~d~%" name left-pad)) (do ((prop plist (cddr prop))) ((endp prop)) (when (and (not (member (car prop) '(:width :height))) (numberp (cadr prop))) (format fstream "#define ~a_~a ~d~%" name (substitute #\_ #\- (string-downcase (string (car prop))) :test #'char=) (cadr prop)))) (format fstream "static char ~a_bits[] = {" name) (dotimes (i height) (dotimes (j bytes-per-line) (when (zerop (index-mod count 15)) (terpri fstream) (write-char #\space fstream)) (write-string "0x" fstream) ;; Faster than (format fstream "0x~2,'0x," byte) (let ((byte (aref data count)) (translate "0123456789abcdef")) (declare (type card8 byte)) (write-char (char translate (ldb (byte 4 4) byte)) fstream) (write-char (char translate (ldb (byte 4 0) byte)) fstream)) (index-incf count) (unless (index= count last) (write-char #\, fstream)))) (format fstream "};~%")))))) (defun bitmap-image (&optional plist &rest patterns) ;; Create an image containg pattern ;; PATTERNS are bit-vector constants (e.g. #*10101) ;; If the first parameter is a list, its used as the image property-list. (declare (type (or list bit-vector) plist) (type list patterns)) ;; list of bitvector (declare (clx-values image)) (unless (listp plist) (push plist patterns) (setq plist nil)) (let* ((width (length (first patterns))) (height (length patterns)) (bitarray (make-array (list height width) :element-type 'bit)) (row 0)) (declare (type card16 width height row) (type pixarray-1 bitarray)) (dolist (pattern patterns) (declare (type simple-bit-vector pattern)) (dotimes (col width) (declare (type card16 col)) (setf (aref bitarray row col) (the bit (aref pattern col)))) (incf row)) (create-image :width width :height height :plist plist :data bitarray))) (defun image-pixmap (drawable image &key gcontext width height depth) ;; Create a pixmap containing IMAGE. Size defaults from the image. ;; DEPTH is the pixmap depth. ;; GCONTEXT is used for putting the image into the pixmap. ;; If none is supplied, then one is created, used then freed. (declare (type drawable drawable) (type image image) (type (or null gcontext) gcontext) (type (or null card16) width height) (type (or null card8) depth)) (declare (clx-values pixmap)) (let* ((image-width (image-width image)) (image-height (image-height image)) (image-depth (image-depth image)) (width (or width image-width)) (height (or height image-height)) (depth (or depth image-depth)) (pixmap (create-pixmap :drawable drawable :width width :height height :depth depth)) (gc (or gcontext (create-gcontext :drawable pixmap :foreground 1 :background 0)))) (unless (= depth image-depth) (if (= image-depth 1) (unless gcontext (xlib::required-arg gcontext)) (error "Pixmap depth ~d incompatable with image depth ~d" depth image-depth))) (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext)) ;; Tile when image-width is less than the pixmap width, or ;; the image-height is less than the pixmap height. ;; ??? Would it be better to create a temporary pixmap and ;; ??? let the server do the tileing? (do ((x image-width (+ x image-width))) ((>= x width)) (copy-area pixmap gc 0 0 image-width image-height pixmap x 0) (incf image-width image-width)) (do ((y image-height (+ y image-height))) ((>= y height)) (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y) (incf image-height image-height)) (unless gcontext (free-gcontext gc)) pixmap)) cmucl-21a/src/clx/input.lisp000066400000000000000000002216121260377556400161720ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11 ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 12/10/87 LGO Created #+cmu (ext:file-comment "$Id: input.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;; Event Resource (defvar *event-free-list* nil) ;; List of unused (processed) events (eval-when (:compile-toplevel :load-toplevel :execute) ;; Maximum number of events supported (the X11 alpha release only has 34) (defconstant +max-events+ 64) (defvar *event-key-vector* (make-array +max-events+ :initial-element nil) "Vector of event keys - See define-event")) (defvar *event-macro-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") (defvar *event-handler-vector* (make-array +max-events+ :initial-element nil) "Vector of event handler functions - See declare-event") (defvar *event-send-vector* (make-array +max-events+ :initial-element nil) "Vector of event sending functions - See declare-event") (defun allocate-event () (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer) (make-reply-buffer +replysize+))) (defun deallocate-event (reply-buffer) (declare (type reply-buffer reply-buffer)) (setf (reply-size reply-buffer) +replysize+) (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer)) ;; Extensions are handled as follows: ;; DEFINITION: Use DEFINE-EXTENSION ;; ;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension. ;; This looks up the code on the display-extension-alist. ;; ;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE ;; at LOAD time to define an internal event-code number ;; (stored in the 'event-code property of the event-name) ;; used to index the following vectors: ;; *event-key-vector* Used for getting the event-key ;; *event-macro-vector* Used for getting the event-parameter getting macros ;; ;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert ;; a server event-code into an internal event-code used to index the following ;; vectors: ;; *event-handler-vector* Used for getting the event-handler function ;; *event-send-vector* Used for getting the event-sending function ;; ;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert ;; internal event-codes to external (server) codes. ;; ;; ERRORS: Use DEFINE-ERROR to define new error decodings. ;; ;; Any event-code greater than 34 is for an extension (defparameter *first-extension-event-code* 35) (defvar *extensions* nil) ;; alist of (extension-name-symbol events errors) (defmacro define-extension (name &key events errors) ;; Define extension NAME with EVENTS and ERRORS. ;; Note: The case of NAME is important. ;; To define the request, Use: ;; (with-buffer-request (display (extension-opcode ,name)) ,@body) ;; See the REQUESTS file for lots of examples. ;; To define event handlers, use declare-event. ;; To define error handlers, use declare-error and define-condition. (declare (type stringable name) (type list events errors)) (let ((name-symbol (kintern name)) ;; Intern name in the keyword package (event-list (mapcar #'canonicalize-event-name events))) `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *extensions* (cons (list ',name-symbol ',event-list ',errors) (delete ',name-symbol *extensions* :key #'car)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun canonicalize-event-name (event) ;; Returns the event name keyword given an event name stringable (declare (type stringable event)) (declare (clx-values event-key)) (kintern event))) (defun extension-event-key-p (key) (dolist (extension *extensions* nil) (when (member key (second extension)) (return t)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun allocate-extension-event-code (name) ;; Allocate an event-code for an extension. This is executed at ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is ;; used at compile-time by macros to index the following vectors: ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR* ;; *EVENT-SEND-VECTOR* (let ((event-code (get name 'event-code))) (declare (type (or null card8) event-code)) (unless event-code ;; First ensure the name is for a declared extension (unless (extension-event-key-p name) (x-type-error name 'event-key)) (setq event-code (position nil *event-key-vector* :start *first-extension-event-code*)) (setf (svref *event-key-vector* event-code) name) (setf (get name 'event-code) event-code)) event-code))) (defun get-internal-event-code (display code) ;; Given an X11 event-code, return the internal event-code. ;; The internal event-code is used for indexing into the following vectors: ;; *event-key-vector* *event-handler-vector* *event-send-vector* ;; Returns NIL when the event-code is for an extension that isn't handled. (declare (type display display) (type card8 code)) (declare (clx-values (or null card8))) (setq code (logand #x7f code)) (if (< code *first-extension-event-code*) code (let* ((code-offset (- code *first-extension-event-code*)) (event-extensions (display-event-extensions display)) (code (if (< code-offset (length event-extensions)) (aref event-extensions code-offset) 0))) (declare (type card8 code-offset code)) (when (zerop code) (x-cerror "Ignore the event" 'unimplemented-event :event-code code :display display)) code))) (defun get-external-event-code (display event) ;; Given an X11 event name, return the event-code (declare (type display display) (type event-key event)) (declare (clx-values card8)) (let ((code (get-event-code event))) (declare (type (or null card8) code)) (when (>= code *first-extension-event-code*) (setq code (+ *first-extension-event-code* (or (position code (display-event-extensions display)) (x-error 'undefined-event :display display :event-name event))))) code)) (defmacro extension-opcode (display name) ;; Returns the major opcode for extension NAME. ;; This is a macro to enable NAME to be interned for fast run-time ;; retrieval. ;; Note: The case of NAME is important. (let ((name-symbol (kintern name))) ;; Intern name in the keyword package `(or (second (assoc ',name-symbol (display-extension-alist ,display))) (x-error 'absent-extension :name ',name-symbol :display ,display)))) (defun initialize-extensions (display) ;; Initialize extensions for DISPLAY (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0)) (extension-alist nil)) (declare (type vector event-extensions) (type list extension-alist)) (dolist (extension *extensions*) (let ((name (first extension)) (events (second extension))) (declare (type keyword name) (type list events)) (multiple-value-bind (major-opcode first-event first-error) (query-extension display name) (declare (type (or null card8) major-opcode first-event first-error)) (when (and major-opcode (plusp major-opcode)) (push (list name major-opcode first-event first-error) extension-alist) (when (plusp first-event) ;; When there are extension events ;; Grow extension vector when needed (let ((max-event (- (+ first-event (length events)) *first-extension-event-code*))) (declare (type card8 max-event)) (when (>= max-event (length event-extensions)) (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8 :initial-element 0))) (declare (type vector new-extensions)) (replace new-extensions event-extensions) (setq event-extensions new-extensions)))) (dolist (event events) (declare (type symbol event)) (setf (aref event-extensions (- first-event *first-extension-event-code*)) (get-event-code event)) (incf first-event))))))) (setf (display-event-extensions display) event-extensions) (setf (display-extension-alist display) extension-alist))) ;; ;; Reply handlers ;; (defvar *pending-command-free-list* nil) (defun start-pending-command (display) (declare (type display display)) (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list* pending-command-next pending-command) (make-pending-command)))) (declare (type pending-command pending-command)) (setf (pending-command-reply-buffer pending-command) nil) (setf (pending-command-process pending-command) (current-process)) (setf (pending-command-sequence pending-command) (ldb (byte 16 0) (1+ (buffer-request-number display)))) ;; Add the pending command to the end of the threaded list of pending ;; commands for the display. (with-event-queue-internal (display) (threaded-nconc pending-command (display-pending-commands display) pending-command-next pending-command)) pending-command)) (defun stop-pending-command (display pending-command) (declare (type display display) (type pending-command pending-command)) (with-event-queue-internal (display) ;; Remove the pending command from the threaded list of pending commands ;; for the display. (threaded-delete pending-command (display-pending-commands display) pending-command-next pending-command) ;; Deallocate any reply buffers in this pending command (loop (let ((reply-buffer (threaded-pop (pending-command-reply-buffer pending-command) reply-next reply-buffer))) (declare (type (or null reply-buffer) reply-buffer)) (if reply-buffer (deallocate-reply-buffer reply-buffer) (return nil))))) ;; Clear pointers to help the Garbage Collector (setf (pending-command-process pending-command) nil) ;; Deallocate this pending-command (threaded-atomic-push pending-command *pending-command-free-list* pending-command-next pending-command) nil) ;;; (defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil)) (defun allocate-reply-buffer (size) (declare (type array-index size)) (if (index<= size +replysize+) (allocate-event) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index) reply-next reply-buffer) (make-reply-buffer (index-ash 1 index)))))) (defun deallocate-reply-buffer (reply-buffer) (declare (type reply-buffer reply-buffer)) (let ((size (reply-size reply-buffer))) (declare (type array-index size)) (if (index<= size +replysize+) (deallocate-event reply-buffer) (let ((index (integer-length (index1- size)))) (declare (type array-index index)) (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index) reply-next reply-buffer))))) ;;; (defun read-error-input (display sequence reply-buffer token) (declare (type display display) (type reply-buffer reply-buffer) (type card16 sequence)) (tagbody start (with-event-queue-internal (display) (let ((command ;; Find any pending command with this sequence number. (threaded-dolist (pending-command (display-pending-commands display) pending-command-next pending-command) (when (= (pending-command-sequence pending-command) sequence) (return pending-command))))) (declare (type (or null pending-command) command)) (cond ((not (null command)) ;; Give this reply to the pending command (threaded-nconc reply-buffer (pending-command-reply-buffer command) reply-next reply-buffer) (process-wakeup (pending-command-process command))) ((member :immediately (display-report-asynchronous-errors display)) ;; No pending command and we should report the error immediately (go report-error)) (t ;; No pending command found, count this as an asynchronous error (threaded-nconc reply-buffer (display-asynchronous-errors display) reply-next reply-buffer))))) (return-from read-error-input nil) report-error (note-input-complete display token) (apply #'report-error display (prog1 (make-error display reply-buffer t) (deallocate-event reply-buffer))))) (defun read-reply-input (display sequence length reply-buffer) (declare (type display display) (type (or null reply-buffer) reply-buffer) (type card16 sequence) (type array-index length)) (unwind-protect (progn (when (index< +replysize+ length) (let ((repbuf nil)) (declare (type (or null reply-buffer) repbuf)) (unwind-protect (progn (setq repbuf (allocate-reply-buffer length)) (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer) 0 +replysize+) (deallocate-event (shiftf reply-buffer repbuf nil))) (when repbuf (deallocate-reply-buffer repbuf)))) (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length) (return-from read-reply-input t)) (setf (reply-data-size reply-buffer) length)) (with-event-queue-internal (display) ;; Find any pending command with this sequence number. (let ((command (threaded-dolist (pending-command (display-pending-commands display) pending-command-next pending-command) (when (= (pending-command-sequence pending-command) sequence) (return pending-command))))) (declare (type (or null pending-command) command)) (when command ;; Give this reply to the pending command (threaded-nconc (shiftf reply-buffer nil) (pending-command-reply-buffer command) reply-next reply-buffer) (process-wakeup (pending-command-process command))))) nil) (when reply-buffer (deallocate-reply-buffer reply-buffer)))) (defun read-event-input (display code reply-buffer) (declare (type display display) (type card8 code) (type reply-buffer reply-buffer)) ;; Push the event in the input buffer on the display's event queue (setf (event-code reply-buffer) (get-internal-event-code display code)) (enqueue-event reply-buffer display) nil) (defun note-input-complete (display token) (declare (type display display)) (when (eq (display-input-in-progress display) token) ;; Indicate that input is no longer in progress (setf (display-input-in-progress display) nil) ;; Let the event process get the first chance to do input (let ((process (display-event-process display))) (when (not (null process)) (process-wakeup process))) ;; Then give processes waiting for command responses a chance (unless (display-input-in-progress display) (with-event-queue-internal (display) (threaded-dolist (command (display-pending-commands display) pending-command-next pending-command) (process-wakeup (pending-command-process command))))))) (defun read-input (display timeout force-output-p predicate &rest predicate-args) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p) (dynamic-extent predicate-args)) (declare (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg predicate)) (let ((reply-buffer nil) (token (or (current-process) (cons nil nil)))) (declare (type (or null reply-buffer) reply-buffer)) (unwind-protect (tagbody loop (when (display-dead display) (x-error 'closed-display :display display)) (when (apply predicate predicate-args) (return-from read-input nil)) ;; Check and see if we have to force output (when (and force-output-p (or (and (not (eq (display-input-in-progress display) token)) (not (conditional-store (display-input-in-progress display) nil token))) (null (buffer-listen display)))) (go force-output)) ;; Ensure that only one process is reading input. (unless (or (eq (display-input-in-progress display) token) (conditional-store (display-input-in-progress display) nil token)) (if (eql timeout 0) (return-from read-input :timeout) (apply #'process-block "CLX Input Lock" #'(lambda (display predicate &rest predicate-args) (declare (type display display) (dynamic-extent predicate-args) (type function predicate) #+clx-ansi-common-lisp (dynamic-extent predicate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg predicate)) (or (apply predicate predicate-args) (null (display-input-in-progress display)) (not (null (display-dead display))))) display predicate predicate-args)) (go loop)) ;; Now start gobbling. (setq reply-buffer (allocate-event)) (with-buffer-input (reply-buffer :sizes (8 16 32)) (let ((type 0)) (declare (type card8 type)) ;; Wait for input before we disallow aborts. (unless (eql timeout 0) (let ((eof-p (buffer-input-wait display timeout))) (when eof-p (return-from read-input eof-p)))) (without-aborts (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+ (if force-output-p 0 timeout)))) (when eof-p (when (eq eof-p :timeout) (if force-output-p (go force-output) (return-from read-input :timeout))) (setf (display-dead display) t) (return-from read-input eof-p))) (setf (reply-data-size reply-buffer) +replysize+) (when (= (the card8 (setq type (read-card8 0))) 1) ;; Normal replies can be longer than +replysize+, so we ;; have to handle them while aborts are still disallowed. (let ((value (read-reply-input display (read-card16 2) (index+ +replysize+ (index* (read-card32 4) 4)) (shiftf reply-buffer nil)))) (when value (return-from read-input value)) (go loop)))) (if (zerop type) (read-error-input display (read-card16 2) (shiftf reply-buffer nil) token) (read-event-input display (read-card8 0) (shiftf reply-buffer nil))))) (go loop) force-output (note-input-complete display token) (display-force-output display) (setq force-output-p nil) (go loop)) (when (not (null reply-buffer)) (deallocate-reply-buffer reply-buffer)) (note-input-complete display token)))) (defun report-asynchronous-errors (display mode) (when (and (display-asynchronous-errors display) (member mode (display-report-asynchronous-errors display))) (let ((aborted t)) (unwind-protect (loop (let ((error (with-event-queue-internal (display) (threaded-pop (display-asynchronous-errors display) reply-next reply-buffer)))) (declare (type (or null reply-buffer) error)) (if error (apply #'report-error display (prog1 (make-error display error t) (deallocate-event error))) (return (setq aborted nil))))) ;; If we get aborted out of this, deallocate all outstanding asynchronous ;; errors. (when aborted (with-event-queue-internal (display) (loop (let ((reply-buffer (threaded-pop (display-asynchronous-errors display) reply-next reply-buffer))) (declare (type (or null reply-buffer) reply-buffer)) (if reply-buffer (deallocate-event reply-buffer) (return nil)))))))))) (defun wait-for-event (display timeout force-output-p) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p)) (let ((event-process-p (not (eql timeout 0)))) (declare (type generalized-boolean event-process-p)) (unwind-protect (loop (when event-process-p (conditional-store (display-event-process display) nil (current-process))) (let ((eof (read-input display timeout force-output-p #'(lambda (display) (declare (type display display)) (or (not (null (display-new-events display))) (and (display-asynchronous-errors display) (member :before-event-handling (display-report-asynchronous-errors display)) t))) display))) (when eof (return eof))) ;; Report asynchronous errors here if the user wants us to. (when event-process-p (report-asynchronous-errors display :before-event-handling)) (when (not (null (display-new-events display))) (return nil))) (when (and event-process-p (eq (display-event-process display) (current-process))) (setf (display-event-process display) nil))))) (defun read-reply (display pending-command) (declare (type display display) (type pending-command pending-command)) (loop (when (read-input display nil nil #'(lambda (pending-command) (declare (type pending-command pending-command)) (not (null (pending-command-reply-buffer pending-command)))) pending-command) (x-error 'closed-display :display display)) (let ((reply-buffer (with-event-queue-internal (display) (threaded-pop (pending-command-reply-buffer pending-command) reply-next reply-buffer)))) (declare (type reply-buffer reply-buffer)) ;; Check for error. (with-buffer-input (reply-buffer) (ecase (read-card8 0) (0 (apply #'report-error display (prog1 (make-error display reply-buffer nil) (deallocate-reply-buffer reply-buffer)))) (1 (return reply-buffer))))))) ;;; (defun event-listen (display &optional (timeout 0)) (declare (type display display) (type (or null number) timeout) (clx-values number-of-events-queued eof-or-timeout)) ;; Returns the number of events queued locally, if any, else nil. Hangs ;; waiting for events, forever if timeout is nil, else for the specified ;; number of seconds. (let* ((current-event-symbol (car (display-current-event-symbol display))) (current-event (and (boundp current-event-symbol) (symbol-value current-event-symbol))) (queue (if current-event (reply-next (the reply-buffer current-event)) (display-event-queue-head display)))) (declare (type symbol current-event-symbol) (type (or null reply-buffer) current-event queue)) (if queue (values (with-event-queue-internal (display :timeout timeout) (threaded-length queue reply-next reply-buffer)) nil) (with-event-queue (display :timeout timeout :inline t) (let ((eof-or-timeout (wait-for-event display timeout nil))) (if eof-or-timeout (values nil eof-or-timeout) (values (with-event-queue-internal (display :timeout timeout) (threaded-length (display-new-events display) reply-next reply-buffer)) nil))))))) (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys) ;; The event is put at the head of the queue if append-p is nil, else the tail. ;; Additional arguments depend on event-key, and are as specified above with ;; declare-event, except that both resource-ids and resource objects are accepted ;; in the event components. (declare (type display display) (type event-key event-key) (type generalized-boolean append-p send-event-p) (dynamic-extent args)) (unless (get event-key 'event-code) (x-type-error event-key 'event-key)) (let* ((event (allocate-event)) (buffer (reply-ibuf8 event)) (event-code (get event-key 'event-code))) (declare (type reply-buffer event) (type buffer-bytes buffer) (type (or null card8) event-code)) (unless event-code (x-type-error event-key 'event-key)) (setf (event-code event) event-code) (with-display (display) (apply (svref *event-send-vector* event-code) display args) (buffer-replace buffer (display-obuf8 display) 0 +replysize+ (index+ 12 (buffer-boffset display))) (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code) (aref buffer 2) 0 (aref buffer 3) 0)) (with-event-queue (display) (if append-p (enqueue-event event display) (with-event-queue-internal (display) (threaded-requeue event (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer)))))) (defun enqueue-event (new-event display) (declare (type reply-buffer new-event) (type display display)) ;; Place EVENT at the end of the event queue for DISPLAY (let* ((event-code (event-code new-event)) (event-key (and (index< event-code (length *event-key-vector*)) (svref *event-key-vector* event-code)))) (declare (type array-index event-code) (type (or null keyword) event-key)) (if (null event-key) (unwind-protect (cerror "Ignore this event" "No handler for ~s event" event-key) (deallocate-event new-event)) (with-event-queue-internal (display) (threaded-enqueue new-event (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer) (unless (display-new-events display) (setf (display-new-events display) new-event)))))) (defmacro define-event (name code) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (svref *event-key-vector* ,code) ',name) (setf (get ',name 'event-code) ,code))) ;; Event names. Used in "type" field in XEvent structures. Not to be ;; confused with event masks above. They start from 2 because 0 and 1 ;; are reserved in the protocol for errors and replies. */ (define-event :key-press 2) (define-event :key-release 3) (define-event :button-press 4) (define-event :button-release 5) (define-event :motion-notify 6) (define-event :enter-notify 7) (define-event :leave-notify 8) (define-event :focus-in 9) (define-event :focus-out 10) (define-event :keymap-notify 11) (define-event :exposure 12) (define-event :graphics-exposure 13) (define-event :no-exposure 14) (define-event :visibility-notify 15) (define-event :create-notify 16) (define-event :destroy-notify 17) (define-event :unmap-notify 18) (define-event :map-notify 19) (define-event :map-request 20) (define-event :reparent-notify 21) (define-event :configure-notify 22) (define-event :configure-request 23) (define-event :gravity-notify 24) (define-event :resize-request 25) (define-event :circulate-notify 26) (define-event :circulate-request 27) (define-event :property-notify 28) (define-event :selection-clear 29) (define-event :selection-request 30) (define-event :selection-notify 31) (define-event :colormap-notify 32) (define-event :client-message 33) (define-event :mapping-notify 34) (defmacro declare-event (event-codes &body declares &environment env) ;; Used to indicate the keyword arguments for handler functions in ;; process-event and event-case. ;; Generates the functions used in SEND-EVENT. ;; A compiler warning is printed when all of EVENT-CODES are not ;; defined by a preceding DEFINE-EXTENSION. ;; The body is a list of declarations, each of which has the form: ;; (type . items) Where type is a data-type, and items is a list of ;; symbol names. The item order corresponds to the order of fields ;; in the event sent by the server. An item may be a list of items. ;; In this case, each item is aliased to the same event field. ;; This is used to give all events an EVENT-WINDOW item. ;; See the INPUT file for lots of examples. (declare (type (or keyword list) event-codes) (type (alist (field-type symbol) (field-names list)) declares)) (when (atom event-codes) (setq event-codes (list event-codes))) (setq event-codes (mapcar #'canonicalize-event-name event-codes)) (let* ((keywords nil) (name (first event-codes)) (get-macro (xintern name '-event-get-macro)) (get-function (xintern name '-event-get)) (put-function (xintern name '-event-put))) (multiple-value-bind (get-code get-index get-sizes) (get-put-items 2 declares nil #'(lambda (type index item args) (flet ((event-get (type index item args) (unless (member type '(pad8 pad16)) `(,(kintern item) (,(getify type) ,index ,@args))))) (if (atom item) (event-get type index item args) (mapcan #'(lambda (item) (event-get type index item args)) item))))) (declare (ignore get-index)) (multiple-value-bind (put-code put-index put-sizes) (get-put-items 2 declares t #'(lambda (type index item args) (unless (member type '(pad8 pad16)) (if (atom item) (progn (push item keywords) `((,(putify type) ,index ,item ,@args))) (let ((names (mapcar #'(lambda (name) (kintern name)) item))) (setq keywords (append item keywords)) `((,(putify type) ,index (check-consistency ',names ,@item) ,@args))))))) (declare (ignore put-index)) `(within-definition (,name declare-event) (defun ,get-macro (display event-key variable) ;; Note: we take pains to macroexpand the get-code here to enable application ;; code to be compiled without having the CLX macros file loaded. `(let ((%buffer ,display)) (declare (ignorable %buffer)) ,(getf `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code (the card8 (logand #x7f (read-card8 0))) :send-event-p (logbitp 7 (read-card8 0)) ,@',(mapcar #'(lambda (form) (clx-macroexpand form env)) get-code)) variable))) (defun ,get-function (display event handler) (declare (type display display) (type reply-buffer event)) (declare (type function handler) #+clx-ansi-common-lisp (dynamic-extent handler) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg handler)) (reading-event (event :display display :sizes (8 16 ,@get-sizes)) (funcall handler :display display :event-key (svref *event-key-vector* (event-code event)) :event-code (logand #x7f (card8-get 0)) :send-event-p (logbitp 7 (card8-get 0)) ,@get-code))) (defun ,put-function (display &key ,@(setq keywords (nreverse keywords)) &allow-other-keys) (declare (type display display)) ,(when (member 'sequence keywords) `(unless sequence (setq sequence (display-request-number display)))) (with-buffer-output (display :sizes ,put-sizes :index (index+ (buffer-boffset display) 12)) ,@put-code)) ,@(mapcar #'(lambda (name) (allocate-extension-event-code name) `(let ((event-code (or (get ',name 'event-code) (allocate-extension-event-code ',name)))) (setf (svref *event-macro-vector* event-code) (function ,get-macro)) (setf (svref *event-handler-vector* event-code) (function ,get-function)) (setf (svref *event-send-vector* event-code) (function ,put-function)))) event-codes) ',name))))) (defun check-consistency (names &rest args) ;; Ensure all args are nil or have the same value. ;; Returns the consistent non-nil value. (let ((value (car args))) (dolist (arg (cdr args)) (if value (when (and arg (not (eq arg value))) (x-error 'inconsistent-parameters :parameters (mapcan #'list names args))) (setq value arg))) value)) (declare-event (:key-press :key-release :button-press :button-release) ;; for key-press and key-release, code is the keycode ;; for button-press and button-release, code is the button number (data code) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) (boolean same-screen-p) ) (declare-event :motion-notify ((data boolean) hint-p) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) (boolean same-screen-p)) (declare-event (:enter-notify :leave-notify) ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind) (card16 sequence) ((or null card32) time) (window root (window event-window)) ((or null window) child) (int16 root-x root-y x y) (card16 state) ((member8 :normal :grab :ungrab) mode) ((bit 0) focus-p) ((bit 1) same-screen-p)) (declare-event (:focus-in :focus-out) ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual :pointer :pointer-root :none)) kind) (card16 sequence) (window (window event-window)) ((member8 :normal :while-grabbed :grab :ungrab) mode)) (declare-event :keymap-notify ((bit-vector256 0) keymap)) (declare-event :exposure (card16 sequence) (window (window event-window)) (card16 x y width height count)) (declare-event :graphics-exposure (card16 sequence) (drawable (drawable event-window)) (card16 x y width height) (card16 minor) ;; Minor opcode (card16 count) (card8 major)) (declare-event :no-exposure (card16 sequence) (drawable (drawable event-window)) (card16 minor) (card8 major)) (declare-event :visibility-notify (card16 sequence) (window (window event-window)) ((member8 :unobscured :partially-obscured :fully-obscured) state)) (declare-event :create-notify (card16 sequence) (window (parent event-window) window) (int16 x y) (card16 width height border-width) (boolean override-redirect-p)) (declare-event :destroy-notify (card16 sequence) (window event-window window)) (declare-event :unmap-notify (card16 sequence) (window event-window window) (boolean configure-p)) (declare-event :map-notify (card16 sequence) (window event-window window) (boolean override-redirect-p)) (declare-event :map-request (card16 sequence) (window (parent event-window) window)) (declare-event :reparent-notify (card16 sequence) (window event-window window parent) (int16 x y) (boolean override-redirect-p)) (declare-event :configure-notify (card16 sequence) (window event-window window) ((or null window) above-sibling) (int16 x y) (card16 width height border-width) (boolean override-redirect-p)) (declare-event :configure-request ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode) (card16 sequence) (window (parent event-window) window) ((or null window) above-sibling) (int16 x y) (card16 width height border-width value-mask)) (declare-event :gravity-notify (card16 sequence) (window event-window window) (int16 x y)) (declare-event :resize-request (card16 sequence) (window (window event-window)) (card16 width height)) (declare-event :circulate-notify (card16 sequence) (window event-window window parent) ((member8 :top :bottom) place)) (declare-event :circulate-request (card16 sequence) (window (parent event-window) window) (pad16 1 2) ((member8 :top :bottom) place)) (declare-event :property-notify (card16 sequence) (window (window event-window)) (keyword atom) ;; keyword ((or null card32) time) ((member8 :new-value :deleted) state)) (declare-event :selection-clear (card16 sequence) ((or null card32) time) (window (window event-window)) (keyword selection) ;; keyword ) (declare-event :selection-request (card16 sequence) ((or null card32) time) (window (window event-window) requestor) (keyword selection target) ((or null keyword) property) ) (declare-event :selection-notify (card16 sequence) ((or null card32) time) (window (window event-window)) (keyword selection target) ((or null keyword) property) ) (declare-event :colormap-notify (card16 sequence) (window (window event-window)) ((or null colormap) colormap) (boolean new-p installed-p)) (declare-event :client-message (data format) (card16 sequence) (window (window event-window)) (keyword type) ((client-message-sequence format) data)) (declare-event :mapping-notify (card16 sequence) ((member8 :modifier :keyboard :pointer) request) (card8 start) ;; first key-code (card8 count)) ;; ;; EVENT-LOOP ;; (defun event-loop-setup (display) (declare (type display display) (clx-values progv-vars progv-vals current-event-symbol current-event-discarded-p-symbol)) (let* ((progv-vars (display-current-event-symbol display)) (current-event-symbol (first progv-vars)) (current-event-discarded-p-symbol (second progv-vars))) (declare (type list progv-vars) (type symbol current-event-symbol current-event-discarded-p-symbol)) (values progv-vars (list (if (boundp current-event-symbol) ;; The current event is already bound, so bind it to the next ;; event. (let ((event (symbol-value current-event-symbol))) (declare (type (or null reply-buffer) event)) (and event (reply-next (the reply-buffer event)))) ;; The current event isn't bound, so bind it to the head of the ;; event queue. (display-event-queue-head display)) nil) current-event-symbol current-event-discarded-p-symbol))) (defun event-loop-step-before (display timeout force-output-p current-event-symbol) (declare (type display display) (type (or null number) timeout) (type generalized-boolean force-output-p) (type symbol current-event-symbol) (clx-values event eof-or-timeout)) (unless (symbol-value current-event-symbol) (let ((eof-or-timeout (wait-for-event display timeout force-output-p))) (when eof-or-timeout (return-from event-loop-step-before (values nil eof-or-timeout)))) (setf (symbol-value current-event-symbol) (display-new-events display))) (let ((event (symbol-value current-event-symbol))) (declare (type reply-buffer event)) (with-event-queue-internal (display) (when (eq event (display-new-events display)) (setf (display-new-events display) (reply-next event)))) (values event nil))) (defun dequeue-event (display event) (declare (type display display) (type reply-buffer event) (clx-values next)) ;; Remove the current event from the event queue (with-event-queue-internal (display) (let ((next (reply-next event)) (head (display-event-queue-head display))) (declare (type (or null reply-buffer) next head)) (when (eq event (display-new-events display)) (setf (display-new-events display) next)) (cond ((eq event head) (threaded-dequeue (display-event-queue-head display) (display-event-queue-tail display) reply-next reply-buffer)) ((null head) (setq next nil)) (t (do* ((previous head current) (current (reply-next previous) (reply-next previous))) ((or (null current) (eq event current)) (when (eq event current) (when (eq current (display-event-queue-tail display)) (setf (display-event-queue-tail display) previous)) (setf (reply-next previous) next))) (declare (type reply-buffer previous) (type (or null reply-buffer) current))))) next))) (defun event-loop-step-after (display event discard-p current-event-symbol current-event-discarded-p-symbol &optional aborted) (declare (type display display) (type reply-buffer event) (type generalized-boolean discard-p aborted) (type symbol current-event-symbol current-event-discarded-p-symbol)) (when (and discard-p (not aborted) (not (symbol-value current-event-discarded-p-symbol))) (discard-current-event display)) (let ((next (reply-next event))) (declare (type (or null reply-buffer) next)) (when (symbol-value current-event-discarded-p-symbol) (setf (symbol-value current-event-discarded-p-symbol) nil) (setq next (dequeue-event display event)) (deallocate-event event)) (setf (symbol-value current-event-symbol) next))) (defmacro event-loop ((display event timeout force-output-p discard-p) &body body) ;; Bind EVENT to the events for DISPLAY. ;; This is the "GUTS" of process-event and event-case. `(let ((.display. ,display) (.timeout. ,timeout) (.force-output-p. ,force-output-p) (.discard-p. ,discard-p)) (declare (type display .display.) (type (or null number) .timeout.) (type generalized-boolean .force-output-p. .discard-p.)) (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.))) (multiple-value-bind (.progv-vars. .progv-vals. .current-event-symbol. .current-event-discarded-p-symbol.) (event-loop-setup .display.) (declare (type list .progv-vars. .progv-vals.) (type symbol .current-event-symbol. .current-event-discarded-p-symbol.)) (progv .progv-vars. .progv-vals. (loop (multiple-value-bind (.event. .eof-or-timeout.) (event-loop-step-before .display. .timeout. .force-output-p. .current-event-symbol.) (declare (type (or null reply-buffer) .event.)) (when (null .event.) (return (values nil .eof-or-timeout.))) (let ((.aborted. t)) (unwind-protect (progn (let ((,event .event.)) (declare (type reply-buffer ,event)) ,@body) (setq .aborted. nil)) (event-loop-step-after .display. .event. .discard-p. .current-event-symbol. .current-event-discarded-p-symbol. .aborted.)))))))))) (defun discard-current-event (display) ;; Discard the current event for DISPLAY. ;; Returns NIL when the event queue is empty, else T. ;; To ensure events aren't ignored, application code should only call ;; this when throwing out of event-case or process-next-event, or from ;; inside even-case, event-cond or process-event when :peek-p is T and ;; :discard-p is NIL. (declare (type display display) (clx-values generalized-boolean)) (let* ((symbols (display-current-event-symbol display)) (event (let ((current-event-symbol (first symbols))) (declare (type symbol current-event-symbol)) (when (boundp current-event-symbol) (symbol-value current-event-symbol))))) (declare (type list symbols) (type (or null reply-buffer) event)) (unless (null event) ;; Set the discarded-p flag (let ((current-event-discarded-p-symbol (second symbols))) (declare (type symbol current-event-discarded-p-symbol)) (when (boundp current-event-discarded-p-symbol) (setf (symbol-value current-event-discarded-p-symbol) t))) ;; Return whether the event queue is empty (not (null (reply-next (the reply-buffer event))))))) ;; ;; PROCESS-EVENT ;; (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t)) ;; If force-output-p is true, first invokes display-force-output. Invokes handler ;; on each queued event until handler returns non-nil, and that returned object is ;; then returned by process-event. If peek-p is true, then the event is not ;; removed from the queue. If discard-p is true, then events for which handler ;; returns nil are removed from the queue, otherwise they are left in place. Hangs ;; until non-nil is generated for some event, or for the specified timeout (in ;; seconds, if given); however, it is acceptable for an implementation to wait only ;; once on network data, and therefore timeout prematurely. Returns nil on ;; timeout. If handler is a sequence, it is expected to contain handler functions ;; specific to each event class; the event code is used to index the sequence, ;; fetching the appropriate handler. Handler is called with raw resource-ids, not ;; with resource objects. The arguments to the handler are described using declare-event. ;; ;; T for peek-p means the event (for which the handler returns non-nil) is not removed ;; from the queue (it is left in place), NIL means the event is removed. (declare (type display display) (type (or null number) timeout) (type generalized-boolean peek-p discard-p force-output-p)) (declare (type t handler) #+clx-ansi-common-lisp (dynamic-extent handler) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera handler)) (event-loop (display event timeout force-output-p discard-p) (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT (event-decoder (and (index< event-code (length *event-handler-vector*)) (svref *event-handler-vector* event-code)))) (declare (type array-index event-code) (type (or null function) event-decoder)) (if event-decoder (let ((event-handler (if (functionp handler) handler (and (type? handler 'sequence) (< event-code (length handler)) (elt handler event-code))))) (if event-handler (let ((result (funcall event-decoder display event event-handler))) (when result (unless peek-p (discard-current-event display)) (return result))) (cerror "Ignore this event" "No handler for ~s event" (svref *event-key-vector* event-code)))) (cerror "Ignore this event" "Server Error: event with unknown event code ~d received." event-code))))) (defun make-event-handlers (&key (type 'array) default) (declare (type t type) ;Sequence type specifier (type (or null function) default) (clx-values sequence)) ;Default handler for initial content ;; Makes a handler sequence suitable for process-event (make-sequence type +max-events+ :initial-element default)) (defun event-handler (handlers event-key) (declare (type sequence handlers) (type event-key event-key) (clx-values function)) ;; Accessor for a handler sequence (elt handlers (position event-key *event-key-vector* :test #'eq))) (defun set-event-handler (handlers event-key handler) (declare (type sequence handlers) (type event-key event-key) (type function handler) (clx-values handler)) (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler)) (defsetf event-handler set-event-handler) ;; ;; EVENT-CASE ;; (defmacro event-case ((&rest args) &body clauses) ;; If force-output-p is true, first invokes display-force-output. Executes the ;; matching clause for each queued event until a clause returns non-nil, and that ;; returned object is then returned by event-case. If peek-p is true, then the ;; event is not removed from the queue. If discard-p is true, then events for ;; which the clause returns nil are removed from the queue, otherwise they are left ;; in place. Hangs until non-nil is generated for some event, or for the specified ;; timeout (in seconds, if given); however, it is acceptable for an implementation ;; to wait only once on network data, and therefore timeout prematurely. Returns ;; nil on timeout. In each clause, event-or-events is an event-key or a list of ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise ;; (but only in the last clause). The keys are not evaluated, and it is an error ;; for the same key to appear in more than one clause. Args is the list of event ;; components of interest; corresponding values (if any) are bound to variables ;; with these names (i.e., the args are variable names, not keywords, the keywords ;; are derived from the variable names). An arg can also be a (keyword var) form, ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is ;; equivalent to having one that returns nil. (declare (arglist (display &key timeout peek-p discard-p (force-output-p t)) (event-or-events ((&rest args) |...|) &body body) |...|)) ;; Event-case is just event-cond with the whole body in the test-form `(event-cond ,args ,@(mapcar #'(lambda (clause) `(,(car clause) ,(cadr clause) (progn ,@(cddr clause)))) clauses))) ;; ;; EVENT-COND ;; (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t)) &body clauses) ;; The clauses of event-cond are of the form: ;; (event-or-events binding-list test-form . body-forms) ;; ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they ;; need not be typed as keywords) or the symbol t ;; or otherwise (but only in the last clause). If ;; no t/otherwise clause appears, it is equivalent ;; to having one that returns nil. The keys are ;; not evaluated, and it is an error for the same ;; key to appear in more than one clause. ;; ;; BINDING-LIST The list of event components of interest. ;; corresponding values (if any) are bound to ;; variables with these names (i.e., the binding-list ;; has variable names, not keywords, the keywords are ;; derived from the variable names). An arg can also ;; be a (keyword var) form, as for keyword args in a ;; lambda list. ;; ;; The matching TEST-FORM for each queued event is executed until a ;; clause's test-form returns non-nil. Then the BODY-FORMS are ;; evaluated, returning the (possibly multiple) values of the last ;; form from event-cond. If there are no body-forms then, if the ;; test-form is non-nil, the value of the test-form is returned as a ;; single value. ;; ;; Options: ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no ;; input is pending. ;; ;; PEEK-P When true, then the event is not removed from the queue. ;; ;; DISCARD-P When true, then events for which the clause returns nil ;; are removed from the queue, otherwise they are left in place. ;; ;; TIMEOUT If NIL, hang until non-nil is generated for some event's ;; test-form. Otherwise return NIL after TIMEOUT seconds have ;; elapsed. ;; (declare (arglist (display &key timeout peek-p discard-p force-output-p) (event-or-events (&rest args) test-form &body body) |...|)) (let ((event (gensym)) (disp (gensym)) (peek (gensym))) `(let ((,disp ,display) (,peek ,peek-p)) (declare (type display ,disp)) (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p) (event-dispatch (,disp ,event ,peek) ,@clauses))))) (defun get-event-code (event) ;; Returns the event code given an event-key (declare (type event-key event)) (declare (clx-values card8)) (or (get event 'event-code) (x-type-error event 'event-key))) (defun universal-event-get-macro (display event-key variable) (getf `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code (the card8 (logand 127 (read-card8 0))) :send-event-p (logbitp 7 (read-card8 0))) variable)) (defmacro event-dispatch ((display event peek-p) &body clauses) ;; Helper macro for event-case ;; CLAUSES are of the form: ;; (event-or-events binding-list test-form . body-forms) (let ((event-key (gensym)) (all-events (make-array +max-events+ :element-type 'bit :initial-element 0))) `(reading-event (,event) (let ((,event-key (svref *event-key-vector* (event-code ,event)))) (case ,event-key ,@(mapcar #'(lambda (clause) ; Translate event-cond clause to case clause (let* ((events (first clause)) (arglist (second clause)) (test-form (third clause)) (body-forms (cdddr clause))) (flet ((event-clause (display peek-p first-form rest-of-forms) (if rest-of-forms `(when ,first-form (unless ,peek-p (discard-current-event ,display)) (return (progn ,@rest-of-forms))) ;; No body forms, return the result of the test form (let ((result (gensym))) `(let ((,result ,first-form)) (when ,result (unless ,peek-p (discard-current-event ,display)) (return ,result))))))) (if (member events '(otherwise t)) ;; code for OTHERWISE clause. ;; Find all events NOT used by other clauses (let ((keys (do ((i 0 (1+ i)) (key nil) (result nil)) ((>= i +max-events+) result) (setq key (svref *event-key-vector* i)) (when (and key (zerop (aref all-events i))) (push key result))))) `(otherwise (binding-event-values (,display ,event-key ,(or keys :universal) ,@arglist) ,(event-clause display peek-p test-form body-forms)))) ;; Code for normal clauses (let (true-events) ;; canonicalize event-names (if (consp events) (progn (setq true-events (mapcar #'canonicalize-event-name events)) (dolist (event true-events) (setf (aref all-events (get-event-code event)) 1))) (setf true-events (canonicalize-event-name events) (aref all-events (get-event-code true-events)) 1)) `(,true-events (binding-event-values (,display ,event-key ,true-events ,@arglist) ,(event-clause display peek-p test-form body-forms)))))))) clauses)))))) (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body) ;; Execute BODY with the variables in VALUE-LIST bound to components of the ;; EVENT-KEYS events. (unless (consp event-keys) (setq event-keys (list event-keys))) (flet ((var-key (var) (kintern (if (consp var) (first var) var))) (var-symbol (var) (if (consp var) (second var) var))) ;; VARS is an alist of: ;; (component-key ((event-key event-key ...) . extraction-code) ;; ((event-key event-key ...) . extraction-code) ...) ;; There should probably be accessor macros for this, instead of things like cdadr. (let ((vars (mapcar #'list value-list)) (multiple-p nil)) ;; Fill in the VARS alist with event-keys and extraction-code (do ((keys event-keys (cdr keys)) (temp nil)) ((endp keys)) (let* ((key (car keys)) (binder (case key (:universal #'universal-event-get-macro) (otherwise (svref *event-macro-vector* (get-event-code key)))))) (dolist (var vars) (let ((code (funcall binder display event-key (var-key (car var))))) (unless code (warn "~a isn't a component of the ~s event" (var-key (car var)) key)) (if (setq temp (member code (cdr var) :key #'cdr :test #'equal)) (push key (caar temp)) (push `((,key) . ,code) (cdr var))))))) ;; Bind all the values `(let ,(mapcar #'(lambda (var) (if (cddr var) ;; if more than one binding form (progn (setq multiple-p t) (var-symbol (car var))) (list (var-symbol (car var)) (cdadr var)))) vars) ;; When some values come from different places, generate code to set them ,(when multiple-p `(case ,event-key ,@(do ((keys event-keys (cdr keys)) (clauses nil) ;; alist of (event-keys bindings) (clause nil nil) (temp)) ((endp keys) (dolist (clause clauses) (unless (cdar clause) ;; Atomize single element lists (setf (car clause) (caar clause)))) clauses) ;; Gather up all the bindings associated with (car keys) (dolist (var vars) (when (cddr var) ;; when more than one binding form (dolist (events (cdr var)) (when (member (car keys) (car events)) ;; Optimize for event-window being the same as some other binding (if (setq temp (member (cdr events) clause :key #'caddr :test #'equal)) (setq clause (nconc clause `((setq ,(car var) ,(second (car temp)))))) (push `(setq ,(car var) ,(cdr events)) clause)))))) ;; Merge bindings for (car keys) with other bindings (when clause (if (setq temp (member clause clauses :key #'cdr :test #'equal)) (push (car keys) (caar temp)) (push `((,(car keys)) . ,clause) clauses)))))) ,@body)))) ;;;----------------------------------------------------------------------------- ;;; Error Handling ;;;----------------------------------------------------------------------------- (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *xerror-vector* '#(unknown-error request-error ; 1 bad request code value-error ; 2 integer parameter out of range window-error ; 3 parameter not a Window pixmap-error ; 4 parameter not a Pixmap atom-error ; 5 parameter not an Atom cursor-error ; 6 parameter not a Cursor font-error ; 7 parameter not a Font match-error ; 8 parameter mismatch drawable-error ; 9 parameter not a Pixmap or Window access-error ; 10 attempt to access private resource" alloc-error ; 11 insufficient resources colormap-error ; 12 no such colormap gcontext-error ; 13 parameter not a GContext id-choice-error ; 14 invalid resource ID for this connection name-error ; 15 font or color name does not exist length-error ; 16 request length incorrect; ; internal Xlib error implementation-error ; 17 server is defective )) ) (defun make-error (display event asynchronous) (declare (type display display) (type reply-buffer event) (type generalized-boolean asynchronous)) (reading-event (event) (let* ((error-code (read-card8 1)) (error-key (get-error-key display error-code)) (error-decode-function (get error-key 'error-decode-function)) (params (funcall error-decode-function display event))) (list* error-code error-key :asynchronous asynchronous :current-sequence (display-request-number display) params)))) (defun report-error (display error-code error-key &rest params) (declare (type display display) (dynamic-extent params)) ;; All errors (synchronous and asynchronous) are processed by calling ;; an error handler in the display. The handler is called with the display ;; as the first argument and the error-key as its second argument. If handler is ;; an array it is expected to contain handler functions specific to ;; each error; the error code is used to index the array, fetching the ;; appropriate handler. Any results returned by the handler are ignored;; ;; it is assumed the handler either takes care of the error completely, ;; or else signals. For all core errors, additional keyword/value argument ;; pairs are: ;; :major integer ;; :minor integer ;; :sequence integer ;; :current-sequence integer ;; :asynchronous (member t nil) ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window ;; errors another pair is: ;; :resource-id integer ;; For :atom errors, another pair is: ;; :atom-id integer ;; For :value errors, another pair is: ;; :value integer (let* ((handler (display-error-handler display)) (handler-function (if (type? handler 'sequence) (elt handler error-code) handler))) (apply handler-function display error-key params))) (defun request-name (code &optional display) (if (< code (length *request-names*)) (svref *request-names* code) (dolist (extension (and display (display-extension-alist display)) "unknown") (when (= code (second extension)) (return (first extension)))))) #-(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display) (error-key :reader request-error-error-key) (major :reader request-error-major) (minor :reader request-error-minor) (sequence :reader request-error-sequence) (current-sequence :reader request-error-current-sequence) (asynchronous :reader request-error-asynchronous)) (:report report-request-error)) (defun report-request-error (condition stream) (let ((error-key (request-error-error-key condition)) (asynchronous (request-error-asynchronous condition)) (major (request-error-major condition)) (minor (request-error-minor condition)) (sequence (request-error-sequence condition)) (current-sequence (request-error-current-sequence condition))) (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]" asynchronous error-key (= sequence current-sequence) sequence current-sequence major minor (request-name major (request-error-display condition))))) ;; Since the :report arg is evaluated as (function report-request-error) the ;; define-condition must come after the function definition. #+(or clx-ansi-common-lisp excl lcl3.0 CMU) (define-condition request-error (x-error) ((display :reader request-error-display :initarg :display) (error-key :reader request-error-error-key :initarg :error-key) (major :reader request-error-major :initarg :major) (minor :reader request-error-minor :initarg :minor) (sequence :reader request-error-sequence :initarg :sequence) (current-sequence :reader request-error-current-sequence :initarg :current-sequence) (asynchronous :reader request-error-asynchronous :initarg :asynchronous)) (:report report-request-error)) (define-condition resource-error (request-error) ((resource-id :reader resource-error-resource-id :initarg :resource-id)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " ID #x~x" (resource-error-resource-id condition))))) (define-condition unknown-error (request-error) ((error-code :reader unknown-error-error-code :initarg :error-code)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Error Code ~d." (unknown-error-error-code condition))))) (define-condition access-error (request-error) ()) (define-condition alloc-error (request-error) ()) (define-condition atom-error (request-error) ((atom-id :reader atom-error-atom-id :initarg :atom-id)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Atom-ID #x~x" (atom-error-atom-id condition))))) (define-condition colormap-error (resource-error) ()) (define-condition cursor-error (resource-error) ()) (define-condition drawable-error (resource-error) ()) (define-condition font-error (resource-error) ()) (define-condition gcontext-error (resource-error) ()) (define-condition id-choice-error (resource-error) ()) (define-condition illegal-request-error (request-error) ()) (define-condition length-error (request-error) ()) (define-condition match-error (request-error) ()) (define-condition name-error (request-error) ()) (define-condition pixmap-error (resource-error) ()) (define-condition value-error (request-error) ((value :reader value-error-value :initarg :value)) (:report (lambda (condition stream) (report-request-error condition stream) (format stream " Value ~d." (value-error-value condition))))) (define-condition window-error (resource-error)()) (define-condition implementation-error (request-error) ()) ;;----------------------------------------------------------------------------- ;; Internal error conditions signaled by CLX (define-condition x-type-error (type-error x-error) ((type-string :reader x-type-error-type-string :initarg :type-string)) (:report (lambda (condition stream) (format stream "~s isn't a ~a" (type-error-datum condition) (or (x-type-error-type-string condition) (type-error-expected-type condition)))))) (define-condition closed-display (x-error) ((display :reader closed-display-display :initarg :display)) (:report (lambda (condition stream) (format stream "Attempt to use closed display ~s" (closed-display-display condition))))) (define-condition lookup-error (x-error) ((id :reader lookup-error-id :initarg :id) (display :reader lookup-error-display :initarg :display) (type :reader lookup-error-type :initarg :type) (object :reader lookup-error-object :initarg :object)) (:report (lambda (condition stream) (format stream "ID ~d from display ~s should have been a ~s, but was ~s" (lookup-error-id condition) (lookup-error-display condition) (lookup-error-type condition) (lookup-error-object condition))))) (define-condition connection-failure (x-error) ((major-version :reader connection-failure-major-version :initarg :major-version) (minor-version :reader connection-failure-minor-version :initarg :minor-version) (host :reader connection-failure-host :initarg :host) (display :reader connection-failure-display :initarg :display) (reason :reader connection-failure-reason :initarg :reason)) (:report (lambda (condition stream) (format stream "Connection failure to X~d.~d server ~a display ~d: ~a" (connection-failure-major-version condition) (connection-failure-minor-version condition) (connection-failure-host condition) (connection-failure-display condition) (connection-failure-reason condition))))) (define-condition reply-length-error (x-error) ((reply-length :reader reply-length-error-reply-length :initarg :reply-length) (expected-length :reader reply-length-error-expected-length :initarg :expected-length) (display :reader reply-length-error-display :initarg :display)) (:report (lambda (condition stream) (format stream "Reply length was ~d when ~d words were expected for display ~s" (reply-length-error-reply-length condition) (reply-length-error-expected-length condition) (reply-length-error-display condition))))) (define-condition reply-timeout (x-error) ((timeout :reader reply-timeout-timeout :initarg :timeout) (display :reader reply-timeout-display :initarg :display)) (:report (lambda (condition stream) (format stream "Timeout after waiting ~d seconds for a reply for display ~s" (reply-timeout-timeout condition) (reply-timeout-display condition))))) (define-condition sequence-error (x-error) ((display :reader sequence-error-display :initarg :display) (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence) (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence)) (:report (lambda (condition stream) (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d" (sequence-error-display condition) (sequence-error-req-sequence condition) (sequence-error-msg-sequence condition))))) (define-condition unexpected-reply (x-error) ((display :reader unexpected-reply-display :initarg :display) (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence) (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence) (length :reader unexpected-reply-length :initarg :length)) (:report (lambda (condition stream) (format stream "Display ~s received a server reply when none was expected.~@ Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes." (unexpected-reply-display condition) (unexpected-reply-req-sequence condition) (unexpected-reply-msg-sequence condition) (unexpected-reply-length condition))))) (define-condition missing-parameter (x-error) ((parameter :reader missing-parameter-parameter :initarg :parameter)) (:report (lambda (condition stream) (let ((parm (missing-parameter-parameter condition))) (if (consp parm) (format stream "One or more of the required parameters ~a is missing." parm) (format stream "Required parameter ~a is missing or null." parm)))))) ;; This can be signalled anywhere a pseudo font access fails. (define-condition invalid-font (x-error) ((font :reader invalid-font-font :initarg :font)) (:report (lambda (condition stream) (format stream "Can't access font ~s" (invalid-font-font condition))))) (define-condition device-busy (x-error) ((display :reader device-busy-display :initarg :display)) (:report (lambda (condition stream) (format stream "Device busy for display ~s" (device-busy-display condition))))) (define-condition unimplemented-event (x-error) ((display :reader unimplemented-event-display :initarg :display) (event-code :reader unimplemented-event-event-code :initarg :event-code)) (:report (lambda (condition stream) (format stream "Event code ~d not implemented for display ~s" (unimplemented-event-event-code condition) (unimplemented-event-display condition))))) (define-condition undefined-event (x-error) ((display :reader undefined-event-display :initarg :display) (event-name :reader undefined-event-event-name :initarg :event-name)) (:report (lambda (condition stream) (format stream "Event code ~d undefined for display ~s" (undefined-event-event-name condition) (undefined-event-display condition))))) (define-condition absent-extension (x-error) ((name :reader absent-extension-name :initarg :name) (display :reader absent-extension-display :initarg :display)) (:report (lambda (condition stream) (format stream "Extension ~a isn't defined for display ~s" (absent-extension-name condition) (absent-extension-display condition))))) (define-condition inconsistent-parameters (x-error) ((parameters :reader inconsistent-parameters-parameters :initarg :parameters)) (:report (lambda (condition stream) (format stream "inconsistent-parameters:~{ ~s~}" (inconsistent-parameters-parameters condition))))) (define-condition resource-ids-exhausted (x-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "All X resource IDs are in use.")))) (defun get-error-key (display error-code) (declare (type display display) (type array-index error-code)) ;; Return the error-key associated with error-code (if (< error-code (length *xerror-vector*)) (svref *xerror-vector* error-code) ;; Search the extensions for the error (dolist (entry (display-extension-alist display) 'unknown-error) (let* ((event-name (first entry)) (first-error (fourth entry)) (errors (third (assoc event-name *extensions*)))) (declare (type keyword event-name) (type array-index first-error) (type list errors)) (when (and errors (index<= first-error error-code (index+ first-error (index- (length errors) 1)))) (return (nth (index- error-code first-error) errors))))))) (defmacro define-error (error-key function) ;; Associate a function with ERROR-KEY which will be called with ;; parameters DISPLAY and REPLY-BUFFER and ;; returns a plist of keyword/value pairs which will be passed on ;; to the error handler. A compiler warning is printed when ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION. ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type ;; macros for getting error fields. See DECODE-CORE-ERROR for ;; an example. (declare (type symbol error-key) (type (or symbol list) function)) ;; First ensure the name is for a declared extension (unless (or (find error-key *xerror-vector*) (dolist (extension *extensions*) (when (member error-key (third extension)) (return t)))) (x-type-error error-key 'error-key)) `(setf (get ',error-key 'error-decode-function) (function ,function))) ;; All core errors use this, so we make it available to extensions. (defun decode-core-error (display event &optional arg) ;; All core errors have the following keyword/argument pairs: ;; :major integer ;; :minor integer ;; :sequence integer ;; In addition, many have an additional argument that comes from the ;; same place in the event, but is named differently. When the ARG ;; argument is specified, the keyword ARG with card32 value starting ;; at byte 4 of the event is returned with the other keyword/argument ;; pairs. (declare (type display display) (type reply-buffer event) (type (or null keyword) arg)) (declare (clx-values keyword/arg-plist)) display (reading-event (event) (let* ((sequence (read-card16 2)) (minor-code (read-card16 8)) (major-code (read-card8 10)) (result (list :major major-code :minor minor-code :sequence sequence))) (when arg (setq result (list* arg (read-card32 4) result))) result))) (defun decode-resource-error (display event) (decode-core-error display event :resource-id)) (define-error unknown-error (lambda (display event) (list* :error-code (aref (reply-ibuf8 event) 1) (decode-core-error display event)))) (define-error request-error decode-core-error) ; 1 bad request code (define-error value-error ; 2 integer parameter out of range (lambda (display event) (decode-core-error display event :value))) (define-error window-error decode-resource-error) ; 3 parameter not a Window (define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap (define-error atom-error ; 5 parameter not an Atom (lambda (display event) (decode-core-error display event :atom-id))) (define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor (define-error font-error decode-resource-error) ; 7 parameter not a Font (define-error match-error decode-core-error) ; 8 parameter mismatch (define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window (define-error access-error decode-core-error) ; 10 attempt to access private resource" (define-error alloc-error decode-core-error) ; 11 insufficient resources (define-error colormap-error decode-resource-error) ; 12 no such colormap (define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext (define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection (define-error name-error decode-core-error) ; 15 font or color name does not exist (define-error length-error decode-core-error) ; 16 request length incorrect; ; internal Xlib error (define-error implementation-error decode-core-error) ; 17 server is defective cmucl-21a/src/clx/keysyms.lisp000066400000000000000000000417651260377556400165500ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- ;;; Define lisp character to keysym mappings ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: keysyms.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) (define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) (define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) (define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) (define-keysym-set :kana (keysym 4 0) (keysym 4 255)) (define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) (define-keysym-set :cyrillic (keysym 6 0) (keysym 6 255)) (define-keysym-set :greek (keysym 7 0) (keysym 7 255)) (define-keysym-set :tech (keysym 8 0) (keysym 8 255)) (define-keysym-set :special (keysym 9 0) (keysym 9 255)) (define-keysym-set :publish (keysym 10 0) (keysym 10 255)) (define-keysym-set :apl (keysym 11 0) (keysym 11 255)) (define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) (define-keysym-set :thai (keysym 13 0) (keysym 13 255)) (define-keysym-set :korean (keysym 14 0) (keysym 14 255)) (define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255)) (define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255)) (define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255)) (define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255)) (define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255)) (define-keysym-set :currency (keysym 32 0) (keysym 32 255)) (define-keysym-set :|3270| (keysym 253 0) (keysym 253 255)) (define-keysym-set :xkb (keysym 254 0) (keysym 254 255)) (define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) (define-keysym :character-set-switch character-set-switch-keysym) (define-keysym :left-shift left-shift-keysym) (define-keysym :right-shift right-shift-keysym) (define-keysym :left-control left-control-keysym) (define-keysym :right-control right-control-keysym) (define-keysym :caps-lock caps-lock-keysym) (define-keysym :shift-lock shift-lock-keysym) (define-keysym :left-meta left-meta-keysym) (define-keysym :right-meta right-meta-keysym) (define-keysym :left-alt left-alt-keysym) (define-keysym :right-alt right-alt-keysym) (define-keysym :left-super left-super-keysym) (define-keysym :right-super right-super-keysym) (define-keysym :left-hyper left-hyper-keysym) (define-keysym :right-hyper right-hyper-keysym) (define-keysym #\space 032) (define-keysym #\! 033) (define-keysym #\" 034) (define-keysym #\# 035) (define-keysym #\$ 036) (define-keysym #\% 037) (define-keysym #\& 038) (define-keysym #\' 039) (define-keysym #\( 040) (define-keysym #\) 041) (define-keysym #\* 042) (define-keysym #\+ 043) (define-keysym #\, 044) (define-keysym #\- 045) (define-keysym #\. 046) (define-keysym #\/ 047) (define-keysym #\0 048) (define-keysym #\1 049) (define-keysym #\2 050) (define-keysym #\3 051) (define-keysym #\4 052) (define-keysym #\5 053) (define-keysym #\6 054) (define-keysym #\7 055) (define-keysym #\8 056) (define-keysym #\9 057) (define-keysym #\: 058) (define-keysym #\; 059) (define-keysym #\< 060) (define-keysym #\= 061) (define-keysym #\> 062) (define-keysym #\? 063) (define-keysym #\@ 064) (define-keysym #\A 065 :lowercase 097) (define-keysym #\B 066 :lowercase 098) (define-keysym #\C 067 :lowercase 099) (define-keysym #\D 068 :lowercase 100) (define-keysym #\E 069 :lowercase 101) (define-keysym #\F 070 :lowercase 102) (define-keysym #\G 071 :lowercase 103) (define-keysym #\H 072 :lowercase 104) (define-keysym #\I 073 :lowercase 105) (define-keysym #\J 074 :lowercase 106) (define-keysym #\K 075 :lowercase 107) (define-keysym #\L 076 :lowercase 108) (define-keysym #\M 077 :lowercase 109) (define-keysym #\N 078 :lowercase 110) (define-keysym #\O 079 :lowercase 111) (define-keysym #\P 080 :lowercase 112) (define-keysym #\Q 081 :lowercase 113) (define-keysym #\R 082 :lowercase 114) (define-keysym #\S 083 :lowercase 115) (define-keysym #\T 084 :lowercase 116) (define-keysym #\U 085 :lowercase 117) (define-keysym #\V 086 :lowercase 118) (define-keysym #\W 087 :lowercase 119) (define-keysym #\X 088 :lowercase 120) (define-keysym #\Y 089 :lowercase 121) (define-keysym #\Z 090 :lowercase 122) (define-keysym #\[ 091) (define-keysym #\\ 092) (define-keysym #\] 093) (define-keysym #\^ 094) (define-keysym #\_ 095) (define-keysym #\` 096) (define-keysym #\a 097) (define-keysym #\b 098) (define-keysym #\c 099) (define-keysym #\d 100) (define-keysym #\e 101) (define-keysym #\f 102) (define-keysym #\g 103) (define-keysym #\h 104) (define-keysym #\i 105) (define-keysym #\j 106) (define-keysym #\k 107) (define-keysym #\l 108) (define-keysym #\m 109) (define-keysym #\n 110) (define-keysym #\o 111) (define-keysym #\p 112) (define-keysym #\q 113) (define-keysym #\r 114) (define-keysym #\s 115) (define-keysym #\t 116) (define-keysym #\u 117) (define-keysym #\v 118) (define-keysym #\w 119) (define-keysym #\x 120) (define-keysym #\y 121) (define-keysym #\z 122) (define-keysym #\{ 123) (define-keysym #\| 124) (define-keysym #\} 125) (define-keysym #\~ 126) (progn ;; Semi-standard characters (define-keysym #\rubout (keysym 255 255)) ; :tty (define-keysym #\tab (keysym 255 009)) ; :tty (define-keysym #\linefeed (keysym 255 010)) ; :tty (define-keysym #\page (keysym 009 227)) ; :special (define-keysym #\return (keysym 255 013)) ; :tty (define-keysym #\backspace (keysym 255 008)) ; :tty ) ;;; these keysym definitions are only correct if the underlying lisp's ;;; definition of characters between 160 and 255 match latin1 exactly. ;;; If the characters are in some way locale-dependent (as, I believe, ;;; in Allegro8) or are treated as opaque without any notions of ;;; graphicness or case (as in cmucl and openmcl) then defining these ;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14 #+sbcl (progn (do ((i 160 (+ i 1))) ((>= i 256)) (if (or (<= #xc0 i #xd6) (<= #xd8 i #xde)) (define-keysym (code-char i) i :lowercase (+ i 32)) (define-keysym (code-char i) i)))) #+(or lispm excl) (progn ;; Nonstandard characters (define-keysym #\escape (keysym 255 027)) ; :tty ) #+ti (progn (define-keysym #\Inverted-exclamation-mark 161) (define-keysym #\american-cent-sign 162) (define-keysym #\british-pound-sign 163) (define-keysym #\Currency-sign 164) (define-keysym #\Japanese-yen-sign 165) (define-keysym #\Yen 165) (define-keysym #\Broken-bar 166) (define-keysym #\Section-symbol 167) (define-keysym #\Section 167) (define-keysym #\Diaresis 168) (define-keysym #\Umlaut 168) (define-keysym #\Copyright-sign 169) (define-keysym #\Copyright 169) (define-keysym #\Feminine-ordinal-indicator 170) (define-keysym #\Angle-quotation-left 171) (define-keysym #\Soft-hyphen 173) (define-keysym #\Shy 173) (define-keysym #\Registered-trademark 174) (define-keysym #\Macron 175) (define-keysym #\Degree-sign 176) (define-keysym #\Ring 176) (define-keysym #\Plus-minus-sign 177) (define-keysym #\Superscript-2 178) (define-keysym #\Superscript-3 179) (define-keysym #\Acute-accent 180) (define-keysym #\Greek-mu 181) (define-keysym #\Paragraph-symbol 182) (define-keysym #\Paragraph 182) (define-keysym #\Pilcrow-sign 182) (define-keysym #\Middle-dot 183) (define-keysym #\Cedilla 184) (define-keysym #\Superscript-1 185) (define-keysym #\Masculine-ordinal-indicator 186) (define-keysym #\Angle-quotation-right 187) (define-keysym #\Fraction-1/4 188) (define-keysym #\One-quarter 188) (define-keysym #\Fraction-1/2 189) (define-keysym #\One-half 189) (define-keysym #\Fraction-3/4 190) (define-keysym #\Three-quarters 190) (define-keysym #\Inverted-question-mark 191) (define-keysym #\Multiplication-sign 215) (define-keysym #\Eszet 223) (define-keysym #\Division-sign 247) ) #+ti (progn ;; There are no 7-bit ascii representations for the following ;; European characters, so use int-char to create them to ensure ;; nothing is lost while sending files through the mail. (define-keysym (int-char 192) 192 :lowercase 224) (define-keysym (int-char 193) 193 :lowercase 225) (define-keysym (int-char 194) 194 :lowercase 226) (define-keysym (int-char 195) 195 :lowercase 227) (define-keysym (int-char 196) 196 :lowercase 228) (define-keysym (int-char 197) 197 :lowercase 229) (define-keysym (int-char 198) 198 :lowercase 230) (define-keysym (int-char 199) 199 :lowercase 231) (define-keysym (int-char 200) 200 :lowercase 232) (define-keysym (int-char 201) 201 :lowercase 233) (define-keysym (int-char 202) 202 :lowercase 234) (define-keysym (int-char 203) 203 :lowercase 235) (define-keysym (int-char 204) 204 :lowercase 236) (define-keysym (int-char 205) 205 :lowercase 237) (define-keysym (int-char 206) 206 :lowercase 238) (define-keysym (int-char 207) 207 :lowercase 239) (define-keysym (int-char 208) 208 :lowercase 240) (define-keysym (int-char 209) 209 :lowercase 241) (define-keysym (int-char 210) 210 :lowercase 242) (define-keysym (int-char 211) 211 :lowercase 243) (define-keysym (int-char 212) 212 :lowercase 244) (define-keysym (int-char 213) 213 :lowercase 245) (define-keysym (int-char 214) 214 :lowercase 246) (define-keysym (int-char 215) 215) (define-keysym (int-char 216) 216 :lowercase 248) (define-keysym (int-char 217) 217 :lowercase 249) (define-keysym (int-char 218) 218 :lowercase 250) (define-keysym (int-char 219) 219 :lowercase 251) (define-keysym (int-char 220) 220 :lowercase 252) (define-keysym (int-char 221) 221 :lowercase 253) (define-keysym (int-char 222) 222 :lowercase 254) (define-keysym (int-char 223) 223) (define-keysym (int-char 224) 224) (define-keysym (int-char 225) 225) (define-keysym (int-char 226) 226) (define-keysym (int-char 227) 227) (define-keysym (int-char 228) 228) (define-keysym (int-char 229) 229) (define-keysym (int-char 230) 230) (define-keysym (int-char 231) 231) (define-keysym (int-char 232) 232) (define-keysym (int-char 233) 233) (define-keysym (int-char 234) 234) (define-keysym (int-char 235) 235) (define-keysym (int-char 236) 236) (define-keysym (int-char 237) 237) (define-keysym (int-char 238) 238) (define-keysym (int-char 239) 239) (define-keysym (int-char 240) 240) (define-keysym (int-char 241) 241) (define-keysym (int-char 242) 242) (define-keysym (int-char 243) 243) (define-keysym (int-char 244) 244) (define-keysym (int-char 245) 245) (define-keysym (int-char 246) 246) (define-keysym (int-char 247) 247) (define-keysym (int-char 248) 248) (define-keysym (int-char 249) 249) (define-keysym (int-char 250) 250) (define-keysym (int-char 251) 251) (define-keysym (int-char 252) 252) (define-keysym (int-char 253) 253) (define-keysym (int-char 254) 254) (define-keysym (int-char 255) 255) ) #+lispm ;; Nonstandard characters (progn (define-keysym #\center-dot (keysym 183)) ; :latin-1 (define-keysym #\down-arrow (keysym 008 254)) ; :technical (define-keysym #\alpha (keysym 007 225)) ; :greek (define-keysym #\beta (keysym 007 226)) ; :greek (define-keysym #\and-sign (keysym 008 222)) ; :technical (define-keysym #\not-sign (keysym 172)) ; :latin-1 (define-keysym #\epsilon (keysym 007 229)) ; :greek (define-keysym #\pi (keysym 007 240)) ; :greek (define-keysym #\lambda (keysym 007 235)) ; :greek (define-keysym #\gamma (keysym 007 227)) ; :greek (define-keysym #\delta (keysym 007 228)) ; :greek (define-keysym #\up-arrow (keysym 008 252)) ; :technical (define-keysym #\plus-minus (keysym 177)) ; :latin-1 (define-keysym #\infinity (keysym 008 194)) ; :technical (define-keysym #\partial-delta (keysym 008 239)) ; :technical (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl (define-keysym #\double-arrow (keysym 008 205)) ; :technical (define-keysym #\left-arrow (keysym 008 251)) ; :technical (define-keysym #\right-arrow (keysym 008 253)) ; :technical (define-keysym #\not-equals (keysym 008 189)) ; :technical (define-keysym #\less-or-equal (keysym 008 188)) ; :technical (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical (define-keysym #\equivalence (keysym 008 207)) ; :technical (define-keysym #\or-sign (keysym 008 223)) ; :technical (define-keysym #\integral (keysym 008 191)) ; :technical ;; break isn't null ;; (define-keysym #\null (keysym 255 107)) ; :function (define-keysym #\clear-input (keysym 255 011)) ; :tty (define-keysym #\help (keysym 255 106)) ; :function (define-keysym #\refresh (keysym 255 097)) ; :function (define-keysym #\abort (keysym 255 105)) ; :function (define-keysym #\resume (keysym 255 098)) ; :function (define-keysym #\end (keysym 255 087)) ; :cursor ;;#\universal-quantifier ;;#\existential-quantifier ;;#\circle-plus ;;#\circle-cross same as #\circle-x ) #+genera (progn ;;#\network ;;#\symbol-help (define-keysym #\lozenge (keysym 009 224)) ; :special (define-keysym #\suspend (keysym 255 019)) ; :tty (define-keysym #\function (keysym 255 032)) ; :function (define-keysym #\square (keysym 010 231)) ; :publishing (define-keysym #\circle (keysym 010 230)) ; :publishing (define-keysym #\triangle (keysym 010 232)) ; :publishing (define-keysym #\scroll (keysym 255 086)) ; :cursor (define-keysym #\select (keysym 255 096)) ; :function (define-keysym #\complete (keysym 255 104)) ; :function ) #+ti (progn (define-keysym #\terminal (keysym 255 032)) ; :function (define-keysym #\system (keysym 255 096)) ; :function (define-keysym #\center-arrow (keysym 255 80)) (define-keysym #\left-arrow (keysym 255 081)) ; :cursor (define-keysym #\up-arrow (keysym 255 082)) ; :cursor (define-keysym #\right-arrow (keysym 255 083)) ; :cursor (define-keysym #\down-arrow (keysym 255 084)) ; :cursor (define-keysym #\end (keysym 255 087)) ; :cursor (define-keysym #\undo (keysym 255 101)) ; :function (define-keysym #\break (keysym 255 107)) (define-keysym #\keypad-space (keysym 255 128)) ; :keypad (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad (define-keysym #\f1 (keysym 255 145)) ; :keypad (define-keysym #\f2 (keysym 255 146)) ; :keypad (define-keysym #\f3 (keysym 255 147)) ; :keypad (define-keysym #\f4 (keysym 255 148)) ; :keypad (define-keysym #\f1 (keysym 255 190)) ; :keypad (define-keysym #\f2 (keysym 255 191)) ; :keypad (define-keysym #\f3 (keysym 255 192)) ; :keypad (define-keysym #\f4 (keysym 255 193)) ; :keypad (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad (define-keysym #\keypad-period (keysym 255 174)) ; :keypad (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad (define-keysym #\f1 (keysym 255 192)) ; :function (define-keysym #\f2 (keysym 255 193)) ; :function (define-keysym #\f3 (keysym 255 194)) ; :function (define-keysym #\f4 (keysym 255 195)) ; :function (define-keysym #\network (keysym 255 214)) (define-keysym #\status (keysym 255 215)) (define-keysym #\clear-screen (keysym 255 217)) (define-keysym #\left (keysym 255 218)) (define-keysym #\middle (keysym 255 219)) (define-keysym #\right (keysym 255 220)) (define-keysym #\resume (keysym 255 221)) (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete ) #+ti (progn ;; Explorer specific characters (define-keysym #\Call (keysym 131)) ; :latin-1 (define-keysym #\Macro (keysym 133)) ; :latin-1 (define-keysym #\Quote (keysym 142)) ; :latin-1 (define-keysym #\Hold-output (keysym 143)) ; :latin-1 (define-keysym #\Stop-output (keysym 144)) ; :latin-1 (define-keysym #\Center (keysym 156)) ; :latin-1 (define-keysym #\no-break-space (keysym 160)) ; :latin-1 (define-keysym #\circle-plus (keysym 13)) ; :latin-1 (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 (define-keysym #\circle-cross (keysym 22)) ; :latin-1 ) cmucl-21a/src/clx/macros.lisp000066400000000000000000001177301260377556400163240ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; CLX basically implements a very low overhead remote procedure call ;;; to the server. This file contains macros which generate the code ;;; for both the client AND the server, given a specification of the ;;; interface. This was done to eliminate errors that may occur because ;;; the client and server code get/put bytes in different places, and ;;; it makes it easier to extend the protocol. ;;; This is built on top of BUFFER #+cmu (ext:file-comment "$Id: macros.lisp,v 1.8 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defmacro type-check (value type) value type (when +type-check?+ `(unless (type? ,value ,type) (x-type-error ,value ,type)))) ;;; This variable is used by the required-arg macro just to satisfy compilers. (defvar *required-arg-dummy*) ;;; An error signalling macro use to specify that keyword arguments are required. (defmacro required-arg (name) `(progn (x-error 'missing-parameter :parameter ',name) *required-arg-dummy*)) (defmacro lround (index) ;; Round up to the next 32 bit boundary `(the array-index (logand (index+ ,index 3) -4))) (defmacro wround (index) ;; Round up to the next 16 bit boundary `(the array-index (logand (index+ ,index 1) -2))) ;; ;; Data-type accessor functions ;; ;; These functions translate between lisp data-types and the byte, ;; half-word or word that gets transmitted across the client/server ;; connection (defun index-increment (type) ;; Given a type, return its field width in bytes (let* ((name (if (consp type) (car type) type)) (increment (get name 'byte-width :not-found))) (when (eq increment :not-found) ;; Check for TYPE in a different package (when (not (eq (symbol-package name) *xlib-package*)) (setq name (xintern name)) (setq increment (get name 'byte-width :not-found))) (when (eq increment :not-found) (error "~s isn't a known field accessor" name))) increment)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun getify (name) (xintern name '-get)) (defun putify (name &optional predicate-p) (xintern name '-put (if predicate-p '-predicating ""))) ;;; Use &body so zmacs indents properly (defmacro define-accessor (name (width) &body get-put-macros) ;; The first body form defines the get macro ;; The second body form defines the put macro ;; The third body form is optional, and defines a put macro that does ;; type checking and does a put when ok, else NIL when the type is incorrect. ;; If no third body form is present, then these macros assume that ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. ;; these predicating puts are used by the OR accessor. (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) (when (cdddr get-put-macros) (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name))) (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))) `(within-definition (,name define-accessor) (setf (get ',name 'byte-width) ,(and width (floor width 8))) (defmacro ,(getify name) ,(car get-macro) ,@(cdr get-macro)) (defmacro ,(putify name) ,(car put-macro) ,@(cdr put-macro)) ,@(when +type-check?+ (let ((predicating-put (third get-put-macros))) (when predicating-put `((setf (get ',name 'predicating-put) t) (defmacro ,(putify name t) ,(car predicating-put) ,@(cdr predicating-put))))))))) ) ;; End eval-when (define-accessor card32 (32) ((index) `(read-card32 ,index)) ((index thing) `(write-card32 ,index ,thing))) (define-accessor card29 (32) ((index) `(read-card29 ,index)) ((index thing) `(write-card29 ,index ,thing))) (define-accessor card16 (16) ((index) `(read-card16 ,index)) ((index thing) `(write-card16 ,index ,thing))) (define-accessor card8 (8) ((index) `(read-card8 ,index)) ((index thing) `(write-card8 ,index ,thing))) (define-accessor integer (32) ((index) `(read-int32 ,index)) ((index thing) `(write-int32 ,index ,thing))) (define-accessor int16 (16) ((index) `(read-int16 ,index)) ((index thing) `(write-int16 ,index ,thing))) (define-accessor rgb-val (16) ;; Used for color's ((index) `(card16->rgb-val (read-card16 ,index))) ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing)))) (define-accessor angle (16) ;; Used for drawing arcs ((index) `(int16->radians (read-int16 ,index))) ((index thing) `(write-int16 ,index (radians->int16 ,thing)))) (define-accessor bit (0) ;; Like BOOLEAN, but tests bits ;; only used by declare-event (:enter-notify :leave-notify) ((index bit) `(logbitp ,bit (read-card8 ,index))) ((index thing bit) (if (zerop bit) `(write-card8 ,index (if ,thing 1 0)) `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index)))))) (define-accessor boolean (8) ((index) `(plusp (read-card8 ,index))) ((index thing) `(write-card8 ,index (if ,thing 1 0)))) (define-accessor drawable (32) ((index &optional (buffer '%buffer)) `(lookup-drawable ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (drawable-id ,thing)))) (define-accessor window (32) ((index &optional (buffer '%buffer)) `(lookup-window ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (window-id ,thing)))) (define-accessor pixmap (32) ((index &optional (buffer '%buffer)) `(lookup-pixmap ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (pixmap-id ,thing)))) (define-accessor gcontext (32) ((index &optional (buffer '%buffer)) `(lookup-gcontext ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (gcontext-id ,thing)))) (define-accessor cursor (32) ((index &optional (buffer '%buffer)) `(lookup-cursor ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (cursor-id ,thing)))) (define-accessor colormap (32) ((index &optional (buffer '%buffer)) `(lookup-colormap ,buffer (read-card29 ,index))) ((index thing) `(write-card29 ,index (colormap-id ,thing)))) (define-accessor font (32) ((index &optional (buffer '%buffer)) `(lookup-font ,buffer (read-card29 ,index))) ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive ;; with-buffer-request, issue a compile time error, rather than barf at run-time. ((index thing) (declare (ignore index thing)) (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead."))) ;; Needed to get and put xatom's in events (define-accessor keyword (32) ((index &optional (buffer '%buffer)) `(atom-name ,buffer (read-card29 ,index))) ((index thing &key (buffer '%buffer)) `(write-card29 ,index (or (atom-id ,thing ,buffer) (error "CLX implementation error in KEYWORD-PUT"))))) (define-accessor resource-id (32) ((index) `(read-card29 ,index)) ((index thing) `(write-card29 ,index ,thing))) (define-accessor resource-id-or-nil (32) ((index) (let ((id (gensym))) `(let ((,id (read-card29 ,index))) (and (plusp ,id) ,id)))) ((index thing) `(write-card29 ,index (or ,thing 0)))) (defmacro char-info-get (index) `(make-char-info :left-bearing (int16-get ,index) :right-bearing (int16-get ,(+ index 2)) :width (int16-get ,(+ index 4)) :ascent (int16-get ,(+ index 6)) :descent (int16-get ,(+ index 8)) :attributes (card16-get ,(+ index 10)))) (define-accessor member8 (8) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card8 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card8 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card8 ,index ,value)))))) (define-accessor member16 (16) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card16 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card16 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card16 ,index ,value)))))) (define-accessor member (32) ((index &rest keywords) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) (declare (type (integer 0 (,(length keywords))) ,value)) (type-check ,value '(integer 0 (,(length keywords)))) (svref ',(apply #'vector keywords) ,value)))) ((index thing &rest keywords) `(write-card29 ,index (position ,thing #+lispm ',keywords ;; Lispm's prefer lists #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) ((index thing &rest keywords) (if (cdr keywords) ;; IF more than one (let ((value (gensym))) `(let ((,value (position ,thing #+lispm ',keywords #-lispm (the simple-vector ',(apply #'vector keywords)) :test #'eq))) (and ,value (write-card29 ,index ,value)))) `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0))))) (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list))) (define-accessor member-vector (32) ((index membership-vector) `(member-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor member16-vector (16) ((index membership-vector) `(member16-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor member8-vector (8) ((index membership-vector) `(member8-get ,index ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))) ((index thing membership-vector) `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))) (define-accessor boole-constant (32) ;; this isn't member-vector because we need eql instead of eq ((index) (let ((value (gensym))) `(let ((,value (read-card29 ,index))) (declare (type (integer 0 (,(length +boole-vector+))) ,value)) (type-check ,value '(integer 0 (,(length +boole-vector+)))) (svref +boole-vector+ ,value)))) ((index thing) `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+)))) ((index thing) (let ((value (gensym))) `(let ((,value (position ,thing (the simple-vector +boole-vector+)))) (and ,value (write-card29 ,index ,value)))))) (define-accessor null (32) ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index))) ((index value) (declare (ignore value)) `(write-card32 ,index 0))) (define-accessor pad8 (8) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor pad16 (16) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor pad32 (32) ((index) (declare (ignore index)) nil) ((index value) (declare (ignore index value)) nil)) (define-accessor bit-vector256 (256) ;; used for key-maps ;; REAL-INDEX parameter provided so the default index can be over-ridden. ;; This is needed for the :keymap-notify event where the keymap overlaps ;; the window id. ((index &optional (real-index index) data) `(read-bitvector256 buffer-bbuf ,real-index ,data)) ((index map &optional (real-index index) (buffer '%buffer)) `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map))) (define-accessor string (nil) ((length index &key reply-buffer) `(read-sequence-char ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index)) ((index string &key buffer (start 0) end header-length appending) (unless buffer (setq buffer '%buffer)) (unless header-length (setq header-length (lround index))) (let* ((real-end (if appending (or end `(length ,string)) (gensym))) (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length) ,string ,start ,real-end))) (if appending form `(let ((,real-end ,(or end `(length ,string)))) (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4)) ,form))))) (define-accessor sequence (nil) ((&key length (format 'card32) result-type transform reply-buffer data index start) `(,(ecase format (card8 'read-sequence-card8) (int8 'read-sequence-int8) (card16 'read-sequence-card16) (int16 'read-sequence-int16) (card32 'read-sequence-card32) (int32 'read-sequence-int32)) ,(or reply-buffer '%reply-buffer) ,result-type ,length ,transform ,data ,@(when (or start index) `(,(or start 0))) ,@(when index `(,index)))) ((index data &key (format 'card32) (start 0) end transform buffer appending) (unless buffer (setq buffer '%buffer)) (let* ((real-end (if appending (or end `(length ,data)) (gensym))) (writer (xintern 'write-sequence- format)) (form `(,writer ,buffer (index+ buffer-boffset ,(lround index)) ,data ,start ,real-end ,transform))) (flet ((maker (size) (if appending form (let ((idx `(index- ,real-end ,start))) (unless (= size 1) (setq idx `(index-ceiling ,idx ,size))) `(let ((,real-end ,(or end `(length ,data)))) (write-card16 2 (index+ ,idx ,(index-ceiling index 4))) ,form))))) (ecase format ((card8 int8) (maker 4)) ((card16 int16 char2b) (maker 2)) ((card32 int32) (maker 1))))))) (defmacro client-message-event-get-sequence () '(let* ((format (read-card8 1)) (sequence (make-array (ceiling 160 format) :element-type `(unsigned-byte ,format)))) (declare (type (member 8 16 32) format)) (do ((i 12) (j 0 (index1+ j))) ((>= i 32)) (case format (8 (setf (aref sequence j) (read-card8 i)) (index-incf i)) (16 (setf (aref sequence j) (read-card16 i)) (index-incf i 2)) (32 (setf (aref sequence j) (read-card32 i)) (index-incf i 4)))) sequence)) (defmacro client-message-event-put-sequence (format sequence) `(ecase ,format (8 (sequence-put 12 ,sequence :format card8 :end (min (length ,sequence) 20) :appending t)) (16 (sequence-put 12 ,sequence :format card16 :end (min (length ,sequence) 10) :appending t)) (32 (sequence-put 12 ,sequence :format card32 :end (min (length ,sequence) 5) :appending t)))) ;; Used only in declare-event (define-accessor client-message-sequence (160) ((index format) (declare (ignore index format)) `(client-message-event-get-sequence)) ((index value format) (declare (ignore index)) `(client-message-event-put-sequence ,format ,value))) ;;; ;;; Compound accessors ;;; Accessors that take other accessors as parameters ;;; (define-accessor code (0) ((index) (declare (ignore index)) '(read-card8 0)) ((index value) (declare (ignore index)) `(write-card8 0 ,value)) ((index value) (declare (ignore index)) `(write-card8 0 ,value))) (define-accessor length (0) ((index) (declare (ignore index)) '(read-card16 2)) ((index value) (declare (ignore index)) `(write-card16 2 ,value)) ((index value) (declare (ignore index)) `(write-card16 2 ,value))) (deftype data () 'card8) (define-accessor data (0) ;; Put data in byte 1 of the reqeust ((index &optional stuff) (declare (ignore index)) (if stuff (if (consp stuff) `(,(getify (car stuff)) 1 ,@(cdr stuff)) `(,(getify stuff) 1)) `(read-card8 1))) ((index thing &optional stuff) (if stuff (if (consp stuff) `(macrolet ((write-card32 (index value) index value)) (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) `(,(putify stuff) 1 ,thing)) `(write-card8 1 ,thing))) ((index thing &optional stuff) (if stuff `(and (type? ,thing ',stuff) ,(if (consp stuff) `(macrolet ((write-card32 (index value) index value)) (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff)))) `(,(putify stuff) 1 ,thing))) `(and (type? ,thing 'card8) (write-card8 1 ,thing))))) ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded ;; when using event-case. This is pretty gross. (defmacro or-expand (&rest forms &environment environment) `(cond ,@(mapcar #'(lambda (forms) (mapcar #'(lambda (form) (clx-macroexpand form environment)) forms)) forms))) ;; ;; the OR type ;; (define-accessor or (32) ;; Select from among several types (usually NULL and something else) ((index &rest type-list &environment environment) (do ((types type-list (cdr types)) (value (gensym)) (result)) ((endp types) `(let ((,value (read-card32 ,index))) (macrolet ((read-card32 (index) index ',value) (read-card29 (index) index ',value)) ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment)))) (let ((item (car types)) (args nil)) (when (consp item) (setq args (cdr item) item (car item))) (if (eq item 'null) ;; Special case for NULL (push `((zerop ,value) nil) result) (push `((,(getify item) ,index ,@args)) result))))) ((index value &rest type-list) (do ((types type-list (cdr types)) (result)) ((endp types) `(cond ,@(nreverse result) ,@(when +type-check?+ `((t (x-type-error ,value '(or ,@type-list))))))) (let* ((type (car types)) (type-name type) (args nil)) (when (consp type) (setq args (cdr type) type-name (car type))) (push `(,@(cond ((get type-name 'predicating-put) nil) ((or +type-check?+ (cdr types)) `((type? ,value ',type))) (t '(t))) (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args)) result))))) ;; ;; the MASK type... ;; is used to specify a subset of a collection of "optional" arguments. ;; A mask type consists of a 32 bit mask word followed by a word for each one-bit ;; in the mask. The MASK type is ALWAYS the LAST item in a request. ;; (setf (get 'mask 'byte-width) nil) (defun mask-get (index type-values body-function) (declare (type function body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; This is a function, because it must return more than one form (called by get-put-items) ;; Functions that use this must have a binding for %MASK (let* ((bit 0) (result (mapcar #'(lambda (form) (if (atom form) form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs (prog1 `(when (logbitp ,bit %mask) ;; Execute form when bit is set ,form) (incf bit)))) (get-put-items (+ index 4) type-values nil #'(lambda (type index item args) (declare (ignore index)) (funcall body-function type '(* (incf %index) 4) item args)))))) ;; First form must load %MASK `(,@(when (atom (car result)) (list (pop result))) (progn (setq %mask (read-card32 ,index)) (setq %index ,(ceiling index 4)) ,(car result)) ,@(cdr result)))) ;; MASK-PUT (defun mask-put (index type-values body-function) (declare (type function body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES ;; A 32 bit value follows for each non-nil value. `((let ((%mask 0) (%index ,index)) ,@(let ((bit 1)) (get-put-items index type-values t #'(lambda (type index item args) (declare (ignore index)) (if (or (symbolp item) (constantp item)) `((unless (null ,item) (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) ,@(funcall body-function type `(index-incf %index 4) item args))) `((let ((.item. ,item)) (unless (null .item.) (setq %mask (logior %mask ,(shiftf bit (ash bit 1)))) ,@(funcall body-function type `(index-incf %index 4) '.item. args)))))))) (write-card32 ,index %mask) (write-card16 2 (index-ceiling (index-incf %index 4) 4)) (incf (buffer-boffset %buffer) %index)))) (define-accessor progn (nil) ;; Catch-all for inserting random code ;; Note that code using this is then responsible for setting the request length ((index statement) (declare (ignore index)) statement) ((index statement) (declare (ignore index)) statement)) ; ; Wrapper macros, for use around the above ; ;;; type-check was here, and has been moved up (defmacro check-put (index value type &rest args &environment env) (let* ((var (if (or (symbolp value) (constantp value)) value '.value.)) (body (if (or (null (macroexpand `(type-check ,var ',type) env)) (member type '(or progn pad8 pad16)) (constantp value)) `(,(putify type) ,index ,var ,@args) ;; Do type checking (if (get type 'predicating-put) `(or (,(putify type t) ,index ,var ,@args) (x-type-error ,var ',(if args `(,type ,@args) type))) `(if (type? ,var ',type) (,(putify type) ,index ,var ,@args) (x-type-error ,var ',(if args `(,type ,@args) type))))))) (if (eq var value) body `(let ((,var ,value)) ,body)))) (defun get-put-items (index type-args putp &optional body-function) (declare (type (or null function) body-function) #+clx-ansi-common-lisp (dynamic-extent body-function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg body-function)) ;; Given a lists of the form (type item item ... item) ;; Calls body-function with four arguments, a function name, ;; index, item name, and optional arguments. ;; The results are appended together and retured. (unless body-function (setq body-function #'(lambda (type index item args) `((check-put ,index ,item ,type ,@args))))) (do* ((items type-args (cdr items)) (type (caar items) (caar items)) (args nil nil) (result nil) (sizes nil)) ((endp items) (values result index sizes)) (when (consp type) (setq args (cdr type) type (car type))) (cond ((member type '(return buffer))) ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values (setq result (append result (if putp (mask-put index (cdar items) body-function) (mask-get index (cdar items) body-function))) index nil)) (t (do* ((item (cdar items) (cdr item)) (increment (index-increment type))) ((endp item)) (when (constantp index) (case increment ;Round up index when needed (2 (setq index (wround index))) (4 (setq index (lround index))))) (setq result (append result (funcall body-function type index (car item) args))) (when (constantp index) ;; Variable length requests have null length increment. ;; Variable length requests set the request size ;; & maintain buffer pointers (if (null increment) (setq index nil) (progn (incf index increment) (when (and increment (zerop increment)) (setq increment 1)) (pushnew (* increment 8) sizes))))))))) (defmacro with-buffer-request-internal ((buffer opcode &key length sizes &allow-other-keys) &body type-args) (multiple-value-bind (code index item-sizes) (get-put-items 4 type-args t) (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+)) (sizes (remove-duplicates (append '(8 16) item-sizes sizes)))) `(with-buffer-output (,buffer :length ,length :sizes ,sizes) (setf (buffer-last-request ,buffer) buffer-boffset) (write-card8 0 ,opcode) ;; Stick in the opcode ,@code ,@(when index (setq index (lround index)) `((write-card16 2 ,(ceiling index 4)) (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index)))) (buffer-new-request-number ,buffer))))) (defmacro with-buffer-request ((buffer opcode &rest options &key inline gc-force &allow-other-keys) &body type-args &environment env) (if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.request-body. (.display.) (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args))) #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body.)) (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn) 'with-buffer-request-function-nolock 'with-buffer-request-function) ,buffer ,gc-force #'.request-body.)) `(let ((.display. ,buffer)) (declare (type display .display.)) (with-buffer (.display.) ,@(when gc-force `((force-gcontext-changes-internal ,gc-force))) (multiple-value-prog1 (without-aborts (with-buffer-request-internal (.display. ,opcode ,@options) ,@type-args)) (display-invoke-after-function .display.)))))) (defmacro with-buffer-request-and-reply ((buffer opcode reply-size &key sizes multiple-reply inline) type-args &body reply-forms &environment env) (declare (indentation 0 4 1 4 2 1)) (let* ((inner-reply-body `(with-buffer-input (.reply-buffer. :display .display. ,@(and sizes (list :sizes sizes))) nil ,@reply-forms)) (reply-body (if (or (not (symbolp reply-size)) (constantp reply-size)) inner-reply-body `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.)))) (declare (type array-index ,reply-size)) ,inner-reply-body)))) (if (and (null inline) (macroexpand '(use-closures) env)) `(flet ((.request-body. (.display.) (declare (type display .display.)) (with-buffer-request-internal (.display. ,opcode) ,@type-args)) (.reply-body. (.display. .reply-buffer.) (declare (type display .display.) (type reply-buffer .reply-buffer.)) (progn .display. .reply-buffer. nil) ,reply-body)) #+clx-ansi-common-lisp (declare (dynamic-extent #'.request-body. #'.reply-body.)) (with-buffer-request-and-reply-function ,buffer ,multiple-reply #'.request-body. #'.reply-body.)) `(let ((.display. ,buffer) (.pending-command. nil) (.reply-buffer. nil)) (declare (type display .display.) (type (or null pending-command) .pending-command.) (type (or null reply-buffer) .reply-buffer.)) (unwind-protect (progn (with-buffer (.display.) (setq .pending-command. (start-pending-command .display.)) (without-aborts (with-buffer-request-internal (.display. ,opcode) ,@type-args)) (buffer-force-output .display.) (display-invoke-after-function .display.)) ,@(if multiple-reply `((loop (setq .reply-buffer. (read-reply .display. .pending-command.)) (when ,reply-body (return nil)) (deallocate-reply-buffer (shiftf .reply-buffer. nil)))) `((setq .reply-buffer. (read-reply .display. .pending-command.)) ,reply-body))) (when .reply-buffer. (deallocate-reply-buffer .reply-buffer.)) (when .pending-command. (stop-pending-command .display. .pending-command.))))))) (defmacro compare-request ((index) &body body) `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index))) (write-int32 (index item) `(= ,item (read-int32 ,index))) (write-card29 (index item) `(= ,item (read-card29 ,index))) (write-int29 (index item) `(= ,item (read-int29 ,index))) (write-card16 (index item) `(= ,item (read-card16 ,index))) (write-int16 (index item) `(= ,item (read-int16 ,index))) (write-card8 (index item) `(= ,item (read-card8 ,index))) (write-int8 (index item) `(= ,item (read-int8 ,index)))) (macrolet ((type-check (value type) value type nil)) (and ,@(get-put-items index body t))))) (defmacro put-items ((index) &body body) `(progn ,@(get-put-items index body t))) (defmacro decode-type (type value) ;; Given an integer and type, return the value (let ((args nil)) (when (consp type) (setq args (cdr type) type (car type))) `(macrolet ((read-card29 (value) value) (read-card32 (value) value) (read-int32 (value) `(card32->int32 ,value)) (read-card16 (value) value) (read-int16 (value) `(card16->int16 ,value)) (read-card8 (value) value) (read-int8 (value) `(int8->card8 ,value))) (,(getify type) ,value ,@args)))) (defmacro encode-type (type value) ;; Given a value and type, return an integer ;; When check-p, do type checking on value (let ((args nil)) (when (consp type) (setq args (cdr type) type (car type))) `(macrolet ((write-card29 (index value) index value) (write-card32 (index value) index value) (write-int32 (index value) index `(int32->card32 ,value)) (write-card16 (index value) index value) (write-int16 (index value) index `(int16->card16 ,value)) (write-card8 (index value) index value) (write-int8 (index value) index `(int8->card8 ,value))) (check-put 0 ,value ,type ,@args)))) (defmacro set-decode-type (type accessor value) `(setf ,accessor (encode-type ,type ,value))) (defsetf decode-type set-decode-type) ;;; ;;; Request codes ;;; (defconstant +x-createwindow+ 1) (defconstant +x-changewindowattributes+ 2) (defconstant +x-getwindowattributes+ 3) (defconstant +x-destroywindow+ 4) (defconstant +x-destroysubwindows+ 5) (defconstant +x-changesaveset+ 6) (defconstant +x-reparentwindow+ 7) (defconstant +x-mapwindow+ 8) (defconstant +x-mapsubwindows+ 9) (defconstant +x-unmapwindow+ 10) (defconstant +x-unmapsubwindows+ 11) (defconstant +x-configurewindow+ 12) (defconstant +x-circulatewindow+ 13) (defconstant +x-getgeometry+ 14) (defconstant +x-querytree+ 15) (defconstant +x-internatom+ 16) (defconstant +x-getatomname+ 17) (defconstant +x-changeproperty+ 18) (defconstant +x-deleteproperty+ 19) (defconstant +x-getproperty+ 20) (defconstant +x-listproperties+ 21) (defconstant +x-setselectionowner+ 22) (defconstant +x-getselectionowner+ 23) (defconstant +x-convertselection+ 24) (defconstant +x-sendevent+ 25) (defconstant +x-grabpointer+ 26) (defconstant +x-ungrabpointer+ 27) (defconstant +x-grabbutton+ 28) (defconstant +x-ungrabbutton+ 29) (defconstant +x-changeactivepointergrab+ 30) (defconstant +x-grabkeyboard+ 31) (defconstant +x-ungrabkeyboard+ 32) (defconstant +x-grabkey+ 33) (defconstant +x-ungrabkey+ 34) (defconstant +x-allowevents+ 35) (defconstant +x-grabserver+ 36) (defconstant +x-ungrabserver+ 37) (defconstant +x-querypointer+ 38) (defconstant +x-getmotionevents+ 39) (defconstant +x-translatecoords+ 40) (defconstant +x-warppointer+ 41) (defconstant +x-setinputfocus+ 42) (defconstant +x-getinputfocus+ 43) (defconstant +x-querykeymap+ 44) (defconstant +x-openfont+ 45) (defconstant +x-closefont+ 46) (defconstant +x-queryfont+ 47) (defconstant +x-querytextextents+ 48) (defconstant +x-listfonts+ 49) (defconstant +x-listfontswithinfo+ 50) (defconstant +x-setfontpath+ 51) (defconstant +x-getfontpath+ 52) (defconstant +x-createpixmap+ 53) (defconstant +x-freepixmap+ 54) (defconstant +x-creategc+ 55) (defconstant +x-changegc+ 56) (defconstant +x-copygc+ 57) (defconstant +x-setdashes+ 58) (defconstant +x-setcliprectangles+ 59) (defconstant +x-freegc+ 60) (defconstant +x-cleartobackground+ 61) (defconstant +x-copyarea+ 62) (defconstant +x-copyplane+ 63) (defconstant +x-polypoint+ 64) (defconstant +x-polyline+ 65) (defconstant +x-polysegment+ 66) (defconstant +x-polyrectangle+ 67) (defconstant +x-polyarc+ 68) (defconstant +x-fillpoly+ 69) (defconstant +x-polyfillrectangle+ 70) (defconstant +x-polyfillarc+ 71) (defconstant +x-putimage+ 72) (defconstant +x-getimage+ 73) (defconstant +x-polytext8+ 74) (defconstant +x-polytext16+ 75) (defconstant +x-imagetext8+ 76) (defconstant +x-imagetext16+ 77) (defconstant +x-createcolormap+ 78) (defconstant +x-freecolormap+ 79) (defconstant +x-copycolormapandfree+ 80) (defconstant +x-installcolormap+ 81) (defconstant +x-uninstallcolormap+ 82) (defconstant +x-listinstalledcolormaps+ 83) (defconstant +x-alloccolor+ 84) (defconstant +x-allocnamedcolor+ 85) (defconstant +x-alloccolorcells+ 86) (defconstant +x-alloccolorplanes+ 87) (defconstant +x-freecolors+ 88) (defconstant +x-storecolors+ 89) (defconstant +x-storenamedcolor+ 90) (defconstant +x-querycolors+ 91) (defconstant +x-lookupcolor+ 92) (defconstant +x-createcursor+ 93) (defconstant +x-createglyphcursor+ 94) (defconstant +x-freecursor+ 95) (defconstant +x-recolorcursor+ 96) (defconstant +x-querybestsize+ 97) (defconstant +x-queryextension+ 98) (defconstant +x-listextensions+ 99) (defconstant +x-setkeyboardmapping+ 100) (defconstant +x-getkeyboardmapping+ 101) (defconstant +x-changekeyboardcontrol+ 102) (defconstant +x-getkeyboardcontrol+ 103) (defconstant +x-bell+ 104) (defconstant +x-changepointercontrol+ 105) (defconstant +x-getpointercontrol+ 106) (defconstant +x-setscreensaver+ 107) (defconstant +x-getscreensaver+ 108) (defconstant +x-changehosts+ 109) (defconstant +x-listhosts+ 110) (defconstant +x-changeaccesscontrol+ 111) (defconstant +x-changeclosedownmode+ 112) (defconstant +x-killclient+ 113) (defconstant +x-rotateproperties+ 114) (defconstant +x-forcescreensaver+ 115) (defconstant +x-setpointermapping+ 116) (defconstant +x-getpointermapping+ 117) (defconstant +x-setmodifiermapping+ 118) (defconstant +x-getmodifiermapping+ 119) (defconstant +x-nooperation+ 127) ;;; Some macros for threaded lists (defmacro threaded-atomic-push (item list next type) (let ((x (gensym)) (y (gensym))) `(let ((,x ,item)) (declare (type ,type ,x)) (loop (let ((,y ,list)) (declare (type (or null ,type) ,y) (optimize (speed 3) (safety 0))) (setf (,next ,x) ,y) (when (conditional-store ,list ,y ,x) (return ,x))))))) (defmacro threaded-atomic-pop (list next type) (let ((y (gensym))) `(loop (let ((,y ,list)) (declare (type (or null ,type) ,y) (optimize (speed 3) (safety 0))) (if (null ,y) (return nil) (when (conditional-store ,list ,y (,next (the ,type ,y))) (setf (,next (the ,type ,y)) nil) (return ,y))))))) (defmacro threaded-nconc (item list next type) (let ((first (gensym)) (x (gensym)) (y (gensym)) (z (gensym))) `(let ((,z ,item) (,first ,list)) (declare (type ,type ,z) (type (or null ,type) ,first) (optimize (speed 3) (safety 0))) (if (null ,first) (setf ,list ,z) (do* ((,x ,first ,y) (,y (,next ,x) (,next ,x))) ((null ,y) (setf (,next ,x) ,z) ,first) (declare (type ,type ,x) (type (or null ,type) ,y))))))) (defmacro threaded-push (item list next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (shiftf (,next ,x) ,list ,x) ,x))) (defmacro threaded-pop (list next type) (let ((x (gensym))) `(let ((,x ,list)) (declare (type (or null ,type) ,x) (optimize (speed 3) (safety 0))) (when ,x (shiftf ,list (,next (the ,type ,x)) nil)) ,x))) (defmacro threaded-enqueue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (if (null ,tail) (threaded-nconc ,x ,head ,next ,type) (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type)) (setf ,tail ,x)))) (defmacro threaded-dequeue (head tail next type) (let ((x (gensym))) `(let ((,x ,head)) (declare (type (or null ,type) ,x) (optimize (speed 3) (safety 0))) (when ,x (when (eq ,x ,tail) (setf ,tail (,next (the ,type ,x)))) (setf ,head (,next (the ,type ,x)))) ,x))) (defmacro threaded-requeue (item head tail next type) (let ((x (gensym))) `(let ((,x ,item)) (declare (type ,type ,x) (optimize (speed 3) (safety 0))) (if (null ,tail) (setf ,tail (setf ,head ,x)) (shiftf (,next ,x) ,head ,x)) ,x))) (defmacro threaded-dolist ((variable list next type) &body body) `(block nil (do* ((,variable ,list (,next (the ,type ,variable)))) ((null ,variable)) (declare (type (or null ,type) ,variable)) ,@body))) (defmacro threaded-delete (item list next type) (let ((x (gensym)) (y (gensym)) (z (gensym)) (first (gensym))) `(let ((,x ,item) (,first ,list)) (declare (type ,type ,x) (type (or null ,type) ,first) (optimize (speed 3) (safety 0))) (when ,first (if (eq ,first ,x) (setf ,first (setf ,list (,next ,x))) (do* ((,y ,first ,z) (,z (,next ,y) (,next ,y))) ((or (null ,z) (eq ,z ,x)) (when (eq ,z ,x) (setf (,next ,y) (,next ,x)))) (declare (type ,type ,y)) (declare (type (or null ,type) ,z))))) (setf (,next ,x) nil) ,first))) (defmacro threaded-length (list next type) (let ((x (gensym)) (count (gensym))) `(do ((,x ,list (,next (the ,type ,x))) (,count 0 (index1+ ,count))) ((null ,x) ,count) (declare (type (or null ,type) ,x) (type array-index ,count) (optimize (speed 3) (safety 0)))))) cmucl-21a/src/clx/manager.lisp000066400000000000000000001013661260377556400164500ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; Window Manager Property functions ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: manager.lisp,v 1.10 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun wm-name (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-name (window) (name) `(set-string-property ,window :WM_NAME ,name)) (defun set-string-property (window property string) (declare (type window window) (type keyword property) (type stringable string)) (change-property window property (string string) :STRING 8 :transform #'char->card8) string) (defun wm-icon-name (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_ICON_NAME :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-icon-name (window) (name) `(set-string-property ,window :WM_ICON_NAME ,name)) (defun wm-client-machine (window) (declare (type window window)) (declare (clx-values string)) (get-property window :WM_CLIENT_MACHINE :type :STRING :result-type 'string :transform #'card8->char)) (defsetf wm-client-machine (window) (name) `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) (defun get-wm-class (window) (declare (type window window)) (declare (clx-values (or null name-string) (or null class-string))) (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8)))) (declare (type (or null (vector card8)) value)) (when value (let* ((name-len (position 0 (the (vector card8) value))) (name (subseq (the (vector card8) value) 0 name-len)) (class (when name-len (subseq (the (vector card8) value) (1+ name-len) (position 0 (the (vector card8) value) :start (1+ name-len)))))) (values (and (plusp (length name)) (map 'string #'card8->char name)) (and (plusp (length class)) (map 'string #'card8->char class))))))) (defun set-wm-class (window resource-name resource-class) (declare (type window window) (type (or null stringable) resource-name resource-class)) (change-property window :WM_CLASS (concatenate '(vector card8) (map '(vector card8) #'char->card8 (string (or resource-name ""))) #(0) (map '(vector card8) #'char->card8 (string (or resource-class ""))) #(0)) :string 8) (values)) (defun wm-command (window) ;; Returns a list whose car is the command and ;; whose cdr is the list of arguments (declare (type window window)) (declare (clx-values list)) (do* ((command-string (get-property window :WM_COMMAND :type :STRING :result-type '(vector card8))) (command nil) (start 0 (1+ end)) (end 0) (len (length command-string))) ((>= start len) (nreverse command)) (setq end (position 0 command-string :start start)) (push (map 'string #'card8->char (subseq command-string start end)) command))) (defsetf wm-command set-wm-command) (defun set-wm-command (window command) ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or ;; equivalent), with elements of command separated by NULL characters. This ;; enables ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) ;; to recover a lisp command. (declare (type window window) (type list command)) (change-property window :WM_COMMAND (apply #'concatenate '(vector card8) (mapcan #'(lambda (c) (list (map '(vector card8) #'char->card8 (with-output-to-string (stream) (with-standard-io-syntax (prin1 c stream)))) #(0))) command)) :string 8) command) ;;----------------------------------------------------------------------------- ;; WM_HINTS (def-clx-class (wm-hints) (input nil :type (or null (member :off :on))) (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive))) (icon-pixmap nil :type (or null pixmap)) (icon-window nil :type (or null window)) (icon-x nil :type (or null card16)) (icon-y nil :type (or null card16)) (icon-mask nil :type (or null pixmap)) (window-group nil :type (or null resource-id)) (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field ;; may be extended in the future ) (defun wm-hints (window) (declare (type window window)) (declare (clx-values wm-hints)) (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector))) (when prop (decode-wm-hints prop (window-display window))))) (defsetf wm-hints set-wm-hints) (defun set-wm-hints (window wm-hints) (declare (type window window) (type wm-hints wm-hints)) (declare (clx-values wm-hints)) (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) wm-hints) (defun decode-wm-hints (vector display) (declare (type (simple-vector 9) vector) (type display display)) (declare (clx-values wm-hints)) (let ((input-hint 0) (state-hint 1) (icon-pixmap-hint 2) (icon-window-hint 3) (icon-position-hint 4) (icon-mask-hint 5) (window-group-hint 6)) (let ((flags (aref vector 0)) (hints (make-wm-hints)) (%buffer display)) (declare (type card32 flags) (type wm-hints hints) (type display %buffer)) (setf (wm-hints-flags hints) flags) (when (logbitp input-hint flags) (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) (when (logbitp state-hint flags) (setf (wm-hints-initial-state hints) (decode-type (member :dont-care :normal :zoom :iconic :inactive) (aref vector 2)))) (when (logbitp icon-pixmap-hint flags) (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) (when (logbitp icon-window-hint flags) (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) (when (logbitp icon-position-hint flags) (setf (wm-hints-icon-x hints) (aref vector 5) (wm-hints-icon-y hints) (aref vector 6))) (when (logbitp icon-mask-hint flags) (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) (when (and (logbitp window-group-hint flags) (> (length vector) 7)) (setf (wm-hints-window-group hints) (aref vector 8))) hints))) (defun encode-wm-hints (wm-hints) (declare (type wm-hints wm-hints)) (declare (clx-values simple-vector)) (let ((input-hint #b1) (state-hint #b10) (icon-pixmap-hint #b100) (icon-window-hint #b1000) (icon-position-hint #b10000) (icon-mask-hint #b100000) (window-group-hint #b1000000) (mask #b1111111) ) (let ((vector (make-array 9 :initial-element 0)) (flags 0)) (declare (type (simple-vector 9) vector) (type card16 flags)) (when (wm-hints-input wm-hints) (setf flags input-hint (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) (when (wm-hints-initial-state wm-hints) (setf flags (logior flags state-hint) (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) (wm-hints-initial-state wm-hints)))) (when (wm-hints-icon-pixmap wm-hints) (setf flags (logior flags icon-pixmap-hint) (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) (when (wm-hints-icon-window wm-hints) (setf flags (logior flags icon-window-hint) (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) (setf flags (logior flags icon-position-hint) (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) (when (wm-hints-icon-mask wm-hints) (setf flags (logior flags icon-mask-hint) (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) (when (wm-hints-window-group wm-hints) (setf flags (logior flags window-group-hint) (aref vector 8) (wm-hints-window-group wm-hints))) (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) vector))) ;;----------------------------------------------------------------------------- ;; WM_SIZE_HINTS (def-clx-class (wm-size-hints) (user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y (user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height ;; the next four fields are obsolete when using a modern window manager ;; (that will use min-width and friends instead), but they should be set by ;; clients in case an old window manager is used (x nil :type (or null int32)) (y nil :type (or null int32)) (width nil :type (or null card32)) (height nil :type (or null card32)) (min-width nil :type (or null card32)) (min-height nil :type (or null card32)) (max-width nil :type (or null card32)) (max-height nil :type (or null card32)) (width-inc nil :type (or null card32)) (height-inc nil :type (or null card32)) (min-aspect nil :type (or null number)) (max-aspect nil :type (or null number)) (base-width nil :type (or null card32)) (base-height nil :type (or null card32)) (win-gravity nil :type (or null win-gravity)) (program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y (program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height ) (defun wm-normal-hints (window) (declare (type window window)) (declare (clx-values wm-size-hints)) (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) (defsetf wm-normal-hints set-wm-normal-hints) (defun set-wm-normal-hints (window hints) (declare (type window window) (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) ;;; OBSOLETE (defun wm-zoom-hints (window) (declare (type window window)) (declare (clx-values wm-size-hints)) (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector))) ;;; OBSOLETE (defsetf wm-zoom-hints set-wm-zoom-hints) ;;; OBSOLETE (defun set-wm-zoom-hints (window hints) (declare (type window window) (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) (defun decode-wm-size-hints (vector) (declare (type (or null (simple-vector *)) vector)) (declare (clx-values (or null wm-size-hints))) (when vector (let ((flags (aref vector 0)) (hints (make-wm-size-hints))) (declare (type card16 flags) (type wm-size-hints hints)) (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) (when (logbitp 4 flags) (setf (wm-size-hints-min-width hints) (aref vector 5) (wm-size-hints-min-height hints) (aref vector 6))) (when (logbitp 5 flags) (setf (wm-size-hints-max-width hints) (aref vector 7) (wm-size-hints-max-height hints) (aref vector 8))) (when (logbitp 6 flags) (setf (wm-size-hints-width-inc hints) (aref vector 9) (wm-size-hints-height-inc hints) (aref vector 10))) (when (logbitp 7 flags) (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12)) (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14)))) (when (> (length vector) 15) ;; This test is for backwards compatibility since old Xlib programs ;; can set a size-hints structure that is too small. See ICCCM. (when (logbitp 8 flags) (setf (wm-size-hints-base-width hints) (aref vector 15) (wm-size-hints-base-height hints) (aref vector 16))) (when (logbitp 9 flags) (setf (wm-size-hints-win-gravity hints) (decode-type (member-vector +win-gravity-vector+) (aref vector 17))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) (when (or (logbitp 1 flags) (logbitp 3 flags)) (setf (wm-size-hints-width hints) (aref vector 3) (wm-size-hints-height hints) (aref vector 4))) hints))) (defun encode-wm-size-hints (hints) (declare (type wm-size-hints hints)) (declare (clx-values simple-vector)) (let ((vector (make-array 18 :initial-element 0)) (flags 0)) (declare (type (simple-vector 18) vector) (type card16 flags)) (when (wm-size-hints-user-specified-position-p hints) (setf (ldb (byte 1 0) flags) 1)) (when (wm-size-hints-user-specified-size-p hints) (setf (ldb (byte 1 1) flags) 1)) (when (wm-size-hints-program-specified-position-p hints) (setf (ldb (byte 1 2) flags) 1)) (when (wm-size-hints-program-specified-size-p hints) (setf (ldb (byte 1 3) flags) 1)) (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) (setf (ldb (byte 1 4) flags) 1 (aref vector 5) (wm-size-hints-min-width hints) (aref vector 6) (wm-size-hints-min-height hints))) (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) (setf (ldb (byte 1 5) flags) 1 (aref vector 7) (wm-size-hints-max-width hints) (aref vector 8) (wm-size-hints-max-height hints))) (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) (setf (ldb (byte 1 6) flags) 1 (aref vector 9) (wm-size-hints-width-inc hints) (aref vector 10) (wm-size-hints-height-inc hints))) (let ((min-aspect (wm-size-hints-min-aspect hints)) (max-aspect (wm-size-hints-max-aspect hints))) (when (and min-aspect max-aspect) (setf (ldb (byte 1 7) flags) 1 min-aspect (rationalize min-aspect) max-aspect (rationalize max-aspect) (aref vector 11) (numerator min-aspect) (aref vector 12) (denominator min-aspect) (aref vector 13) (numerator max-aspect) (aref vector 14) (denominator max-aspect)))) (when (and (wm-size-hints-base-width hints) (wm-size-hints-base-height hints)) (setf (ldb (byte 1 8) flags) 1 (aref vector 15) (wm-size-hints-base-width hints) (aref vector 16) (wm-size-hints-base-height hints))) (when (wm-size-hints-win-gravity hints) (setf (ldb (byte 1 9) flags) 1 (aref vector 17) (encode-type (member-vector +win-gravity-vector+) (wm-size-hints-win-gravity hints)))) ;; Obsolete fields (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) (unless (wm-size-hints-user-specified-position-p hints) (setf (ldb (byte 1 2) flags) 1)) (setf (aref vector 1) (wm-size-hints-x hints) (aref vector 2) (wm-size-hints-y hints))) (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) (unless (wm-size-hints-user-specified-size-p hints) (setf (ldb (byte 1 3) flags) 1)) (setf (aref vector 3) (wm-size-hints-width hints) (aref vector 4) (wm-size-hints-height hints))) (setf (aref vector 0) flags) vector)) ;;----------------------------------------------------------------------------- ;; Icon_Size ;; Use the same intermediate structure as WM_SIZE_HINTS (defun icon-sizes (window) (declare (type window window)) (declare (clx-values wm-size-hints)) (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector))) (declare (type (or null (simple-vector 6)) vector)) (when vector (make-wm-size-hints :min-width (aref vector 0) :min-height (aref vector 1) :max-width (aref vector 2) :max-height (aref vector 3) :width-inc (aref vector 4) :height-inc (aref vector 5))))) (defsetf icon-sizes set-icon-sizes) (defun set-icon-sizes (window wm-size-hints) (declare (type window window) (type wm-size-hints wm-size-hints)) (let ((vector (vector (wm-size-hints-min-width wm-size-hints) (wm-size-hints-min-height wm-size-hints) (wm-size-hints-max-width wm-size-hints) (wm-size-hints-max-height wm-size-hints) (wm-size-hints-width-inc wm-size-hints) (wm-size-hints-height-inc wm-size-hints)))) (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) wm-size-hints)) ;;----------------------------------------------------------------------------- ;; WM-Protocols (defun wm-protocols (window) (map 'list #'(lambda (id) (atom-name (window-display window) id)) (get-property window :WM_PROTOCOLS :type :ATOM))) (defsetf wm-protocols set-wm-protocols) (defun set-wm-protocols (window protocols) (change-property window :WM_PROTOCOLS (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) protocols) :ATOM 32) protocols) ;;----------------------------------------------------------------------------- ;; WM-Colormap-windows (defun wm-colormap-windows (window) (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW :transform #'(lambda (id) (lookup-window (window-display window) id))))) (defsetf wm-colormap-windows set-wm-colormap-windows) (defun set-wm-colormap-windows (window colormap-windows) (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 :transform #'window-id) colormap-windows) ;;----------------------------------------------------------------------------- ;; Transient-For (defun transient-for (window) (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list))) (and prop (lookup-window (window-display window) (car prop))))) (defsetf transient-for set-transient-for) (defun set-transient-for (window transient) (declare (type window window transient)) (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32) transient) ;;----------------------------------------------------------------------------- ;; Set-WM-Properties (defun set-wm-properties (window &rest options &key name icon-name resource-name resource-class command client-machine hints normal-hints zoom-hints ;; the following are used for wm-normal-hints (user-specified-position-p nil usppp) (user-specified-size-p nil usspp) (program-specified-position-p nil psppp) (program-specified-size-p nil psspp) x y width height min-width min-height max-width max-height width-inc height-inc min-aspect max-aspect base-width base-height win-gravity ;; the following are used for wm-hints input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group) ;; Set properties for WINDOW. (declare (arglist window &rest options &key name icon-name resource-name resource-class command client-machine hints normal-hints ;; the following are used for wm-normal-hints user-specified-position-p user-specified-size-p program-specified-position-p program-specified-size-p min-width min-height max-width max-height width-inc height-inc min-aspect max-aspect base-width base-height win-gravity ;; the following are used for wm-hints input initial-state icon-pixmap icon-window icon-x icon-y icon-mask window-group)) (declare (type window window) (type (or null stringable) name icon-name resource-name resource-class client-machine) (type (or null list) command) (type (or null wm-hints) hints) (type (or null wm-size-hints) normal-hints zoom-hints) (type generalized-boolean user-specified-position-p user-specified-size-p) (type generalized-boolean program-specified-position-p program-specified-size-p) (type (or null int32) x y) (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) (type (or null win-gravity) win-gravity) (type (or null number) min-aspect max-aspect) (type (or null (member :off :on)) input) (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) (type (or null pixmap) icon-pixmap icon-mask) (type (or null window) icon-window) (type (or null card32) icon-x icon-y) (type (or null resource-id) window-group) (dynamic-extent options)) (when name (setf (wm-name window) name)) (when icon-name (setf (wm-icon-name window) icon-name)) (when client-machine (setf (wm-client-machine window) client-machine)) (when (or resource-name resource-class) (set-wm-class window resource-name resource-class)) (when command (setf (wm-command window) command)) ;; WM-HINTS (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window :icon-x :icon-y :icon-mask :window-group)) (when (getf options arg) (return t))) (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) (when input (setf (wm-hints-input wm-hints) input)) (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) (when window-group (setf (wm-hints-window-group wm-hints) window-group)) (setf (wm-hints window) wm-hints)) (when hints (setf (wm-hints window) hints))) ;; WM-NORMAL-HINTS (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height :width-inc :height-inc :min-aspect :max-aspect :user-specified-position-p :user-specified-size-p :program-specified-position-p :program-specified-size-p :base-width :base-height :win-gravity)) (when (getf options arg) (return t))) (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) (when x (setf (wm-size-hints-x size) x)) (when y (setf (wm-size-hints-y size) y)) (when width (setf (wm-size-hints-width size) width)) (when height (setf (wm-size-hints-height size) height)) (when min-width (setf (wm-size-hints-min-width size) min-width)) (when min-height (setf (wm-size-hints-min-height size) min-height)) (when max-width (setf (wm-size-hints-max-width size) max-width)) (when max-height (setf (wm-size-hints-max-height size) max-height)) (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) (when base-width (setf (wm-size-hints-base-width size) base-width)) (when base-height (setf (wm-size-hints-base-height size) base-height)) (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) (when usppp (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) (when usspp (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) (when psppp (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) (when psspp (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) (setf (wm-normal-hints window) size)) (when normal-hints (setf (wm-normal-hints window) normal-hints))) (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) ) ;;; OBSOLETE (defun set-standard-properties (window &rest options) (declare (dynamic-extent options)) (apply #'set-wm-properties window options)) ;;----------------------------------------------------------------------------- ;; WM Control (defun iconify-window (window screen) (declare (type window window) (type screen screen)) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :client-message '(:substructure-redirect :substructure-notify) :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) (defun withdraw-window (window screen) (declare (type window window) (type screen screen)) (unmap-window window) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) :window window :event-window root :configure-p nil))) ;;----------------------------------------------------------------------------- ;; Colormaps (def-clx-class (standard-colormap (:copier nil) (:predicate nil)) (colormap nil :type (or null colormap)) (base-pixel 0 :type pixel) (max-color nil :type (or null color)) (mult-color nil :type (or null color)) (visual nil :type (or null visual-info)) (kill nil :type (or (member nil :release-by-freeing-colormap) drawable gcontext cursor colormap font))) (defun rgb-colormaps (window property) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (list (make-standard-colormap :colormap (lookup-colormap (window-display window) (aref prop 0)) :base-pixel (aref prop 7) :max-color (make-color :red (card16->rgb-val (aref prop 1)) :green (card16->rgb-val (aref prop 3)) :blue (card16->rgb-val (aref prop 5))) :mult-color (make-color :red (card16->rgb-val (aref prop 2)) :green (card16->rgb-val (aref prop 4)) :blue (card16->rgb-val (aref prop 6))) :visual (and (<= 9 (length prop)) (visual-info (window-display window) (aref prop 8))) :kill (and (<= 10 (length prop)) (let ((killid (aref prop 9))) (if (= killid 1) :release-by-freeing-colormap (lookup-resource-id (window-display window) killid))))))))) (defsetf rgb-colormaps set-rgb-colormaps) (defun set-rgb-colormaps (window property maps) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property) (type list maps)) (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) (index -1)) (dolist (map maps) (setf (aref prop (incf index)) (encode-type colormap (standard-colormap-colormap map))) (setf (aref prop (incf index)) (encode-type rgb-val (color-red (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-green (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) (setf (aref prop (incf index)) (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) (standard-colormap-base-pixel map)) (setf (aref prop (incf index)) (visual-info-id (standard-colormap-visual map))) (setf (aref prop (incf index)) (let ((kill (standard-colormap-kill map))) (etypecase kill (symbol (ecase kill ((nil) 0) ((:release-by-freeing-colormap) 1))) (drawable (drawable-id kill)) (gcontext (gcontext-id kill)) (cursor (cursor-id kill)) (colormap (colormap-id kill)) (font (font-id kill)))))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;; OBSOLETE (defun get-standard-colormap (window property) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (declare (clx-values colormap base-pixel max-color mult-color)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (values (lookup-colormap (window-display window) (aref prop 0)) (aref prop 7) ;Base Pixel (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color :green (card16->rgb-val (aref prop 3)) :blue (card16->rgb-val (aref prop 5))) (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color :green (card16->rgb-val (aref prop 4)) :blue (card16->rgb-val (aref prop 6))))))) ;;; OBSOLETE (defun set-standard-colormap (window property colormap base-pixel max-color mult-color) (declare (type window window) (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP :RGB_GREEN_MAP :RGB_BLUE_MAP) property) (type colormap colormap) (type pixel base-pixel) (type color max-color mult-color)) (let ((prop (vector (encode-type colormap colormap) (encode-type rgb-val (color-red max-color)) (encode-type rgb-val (color-red mult-color)) (encode-type rgb-val (color-green max-color)) (encode-type rgb-val (color-green mult-color)) (encode-type rgb-val (color-blue max-color)) (encode-type rgb-val (color-blue mult-color)) base-pixel))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;----------------------------------------------------------------------------- ;; Cut-Buffers (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) (transform #'card8->char) (start 0) end) ;; Return the contents of cut-buffer BUFFER (declare (type display display) (type (integer 0 7) buffer) (type xatom type) (type array-index start) (type (or null array-index) end) (type t result-type) ;a sequence type (type (or null (function (integer) t)) transform)) (declare (clx-values sequence type format bytes-after)) (let* ((root (screen-root (first (display-roots display)))) (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) buffer))) (get-property root property :type type :result-type result-type :start start :end end :transform transform))) ;; Implement the following: ;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8) ;; (transform #'char->card8) (start 0) end) (data) ;; In order to avoid having to pass positional parameters to set-cut-buffer, ;; We've got to do the following. WHAT A PAIN... #-clx-ansi-common-lisp (define-setf-method cut-buffer (display &rest option-list) (declare (dynamic-extent option-list)) (do* ((options (copy-list option-list)) (option options (cddr option)) (store (gensym)) (dtemp (gensym)) (temps (list dtemp)) (values (list display))) ((endp option) (values (nreverse temps) (nreverse values) (list store) `(set-cut-buffer ,store ,dtemp ,@options) `(cut-buffer ,@options))) (unless (member (car option) '(:buffer :type :format :start :end :transform)) (error "Keyword arg ~s isn't recognized" (car option))) (let ((x (gensym))) (push x temps) (push (cadr option) values) (setf (cadr option) x)))) (defun #+clx-ansi-common-lisp (setf cut-buffer) #-clx-ansi-common-lisp set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8) (start 0) end (transform #'char->card8)) (declare (type sequence data) (type display display) (type (integer 0 7) buffer) (type xatom type) (type (member 8 16 32) format) (type array-index start) (type (or null array-index) end) (type (or null (function (integer) t)) transform)) (let* ((root (screen-root (first (display-roots display)))) (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) buffer))) (change-property root property data type format :transform transform :start start :end end) data)) (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t)) ;; Positive rotates left, negative rotates right (opposite of actual protocol request). ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. (declare (type display display) (type int16 delta) (type generalized-boolean careful-p)) (let* ((root (screen-root (first (display-roots display)))) (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) (when careful-p (let ((props (list-properties root))) (dotimes (i 8) (unless (member (aref buffers i) props) (setf (cut-buffer display :buffer i) ""))))) (rotate-properties root buffers delta))) cmucl-21a/src/clx/package.lisp000066400000000000000000000574371260377556400164420ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; -*- ;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge, ;;; Massachusetts. All Rights Reserved. ;;; ;;; Permission to use, copy, modify, and distribute this software and its ;;; documentation for any purpose and without fee is hereby granted, provided ;;; that the above copyright notice appear in all copies and that both that ;;; copyright notice and this permission notice appear in supporting ;;; documentation, and that the name MIT not be used in advertising or ;;; publicity pertaining to distribution of the software without specific, ;;; written prior permission. #+cmu (ext:file-comment "$Id: package.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") ;;; The CLtL way #-clx-ansi-common-lisp (lisp:in-package :xlib :use '(:lisp)) #+(and (or kcl ibcl) (not clx-ansi-common-lisp)) (shadow '( rational )) #+(and CMU (not clx-ansi-common-lisp)) (shadow '(define-condition)) #+(and lispm (not clx-ansi-common-lisp)) (import '( sys:arglist sys:with-stack-list sys:with-stack-list* )) #+(and Genera (not clx-ansi-common-lisp)) (import '( future-common-lisp:print-unreadable-object future-common-lisp:with-standard-io-syntax zwei:indentation )) #+(and lcl3.0 (not clx-ansi-common-lisp)) (import '( lcl:arglist lcl:dynamic-extent lcl:type-error lucid::type-error-datum lucid::type-error-expected-type )) #+(and excl (not clx-ansi-common-lisp)) (import '( excl::arglist excl::dynamic-extent excl::type-error excl::type-error-datum excl::type-error-expected-type )) #+(and allegro (not clx-ansi-common-lisp)) (import '( excl::without-interrupts )) #-clx-ansi-common-lisp (export '( *version* access-control access-error access-hosts activate-screen-saver add-access-host add-resource add-to-save-set alist alloc-color alloc-color-cells alloc-color-planes alloc-error allow-events angle arc-seq array-index atom-error atom-name bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image boole-constant boolean card16 card29 card32 card8 card8->char change-active-pointer-grab change-keyboard-control change-keyboard-mapping change-pointer-control change-property char->card8 char-ascent char-attributes char-descent char-left-bearing char-right-bearing char-width character->keysyms character-in-map-p circulate-window-down circulate-window-up clear-area close-display close-down-mode close-font closed-display color color-blue color-green color-p color-red color-rgb colormap colormap-display colormap-equal colormap-error colormap-id colormap-p colormap-plist colormap-visual-info connection-failure convert-selection copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components copy-image copy-plane create-colormap create-cursor create-gcontext create-glyph-cursor create-image create-pixmap create-window cursor cursor-display cursor-equal cursor-error cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error default-error-handler default-keysym-index default-keysym-translate define-error define-extension define-gcontext-accessor define-keysym define-keysym-set delete-property delete-resource destroy-subwindows destroy-window device-busy device-event-mask device-event-mask-class discard-current-event discard-font-info display display-after-function display-authorization-data display-authorization-name display-bitmap-format display-byte-order display-default-screen display-display display-error-handler display-extended-max-request-length display-finish-output display-force-output display-host display-image-lsb-first-p display-invoke-after-function display-keycode-range display-max-keycode display-max-request-length display-min-keycode display-motion-buffer-size display-nscreens display-p display-pixmap-formats display-plist display-protocol-major-version display-protocol-minor-version display-protocol-version display-release-number display-report-asynchronous-errors display-resource-id-base display-resource-id-mask display-roots display-vendor display-vendor-name display-xdefaults display-xid draw-arc draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph draw-image-glyphs draw-line draw-lines draw-point draw-points draw-rectangle draw-rectangles draw-segments drawable drawable-border-width drawable-depth drawable-display drawable-equal drawable-error drawable-height drawable-id drawable-p drawable-plist drawable-root drawable-width drawable-x drawable-y error-key event-case event-cond event-handler event-key event-listen event-mask event-mask-class extension-opcode find-atom font font-all-chars-exist-p font-ascent font-default-char font-descent font-direction font-display font-equal font-error font-id font-max-byte1 font-max-byte2 font-max-char font-min-byte1 font-min-byte2 font-min-char font-name font-p font-path font-plist font-properties font-property fontable force-gcontext-changes free-colormap free-colors free-cursor free-gcontext free-pixmap gcontext gcontext-arc-mode gcontext-background gcontext-cache-p gcontext-cap-style gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule gcontext-fill-style gcontext-font gcontext-foreground gcontext-function gcontext-id gcontext-join-style gcontext-key gcontext-line-style gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x gcontext-ts-y generalized-boolean get-external-event-code get-image get-property get-raw-image get-resource get-search-resource get-search-table get-standard-colormap get-wm-class global-pointer-position grab-button grab-key grab-keyboard grab-pointer grab-server grab-status icon-sizes iconify-window id-choice-error illegal-request-error image image-blue-mask image-depth image-green-mask image-height image-name image-pixmap image-plist image-red-mask image-width image-x image-x-hot image-x-p image-xy image-xy-bitmap-list image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p image-z-pixarray implementation-error input-focus install-colormap installed-colormaps int16 int32 int8 intern-atom invalid-font keyboard-control keyboard-mapping keycode->character keycode->keysym keysym keysym->character keysym->keycodes keysym-in-map-p keysym-set kill-client kill-temporary-clients length-error list-extensions list-font-names list-fonts list-properties lookup-color lookup-error make-color make-event-handlers make-event-keys make-event-mask make-resource-database make-state-keys make-state-mask make-wm-hints make-wm-size-hints map-resource map-subwindows map-window mapping-notify mask16 mask32 match-error max-char-ascent max-char-attributes max-char-descent max-char-left-bearing max-char-right-bearing max-char-width merge-resources min-char-ascent min-char-attributes min-char-descent min-char-left-bearing min-char-right-bearing min-char-width missing-parameter modifier-key modifier-mapping modifier-mask motion-events name-error no-operation open-display open-font pixarray pixel pixmap pixmap-display pixmap-equal pixmap-error pixmap-format pixmap-format-bits-per-pixel pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad pixmap-id pixmap-p pixmap-plist point-seq pointer-control pointer-event-mask pointer-event-mask-class pointer-mapping pointer-position process-event put-image put-raw-image query-best-cursor query-best-stipple query-best-tile query-colors query-extension query-keymap query-pointer query-tree queue-event read-bitmap-file read-resources recolor-cursor rect-seq remove-access-host remove-from-save-set reparent-window repeat-seq reply-length-error reply-timeout request-error reset-screen-saver resource-database resource-database-timestamp resource-error resource-id resource-key rgb-colormaps rgb-val root-resources rotate-cut-buffers rotate-properties screen screen-backing-stores screen-black-pixel screen-default-colormap screen-depths screen-event-mask-at-open screen-height screen-height-in-millimeters screen-max-installed-maps screen-min-installed-maps screen-p screen-plist screen-root screen-root-depth screen-root-visual screen-root-visual-info screen-save-unders-p screen-saver screen-white-pixel screen-width screen-width-in-millimeters seg-seq selection-owner send-event sequence-error set-access-control set-close-down-mode set-input-focus set-modifier-mapping set-pointer-mapping set-screen-saver set-selection-owner set-standard-colormap set-standard-properties set-wm-class set-wm-properties set-wm-resources state-keysym-p state-mask-key store-color store-colors stringable text-extents text-width timestamp transient-for translate-coordinates translate-default translation-function type-error undefine-keysym unexpected-reply ungrab-button ungrab-key ungrab-keyboard ungrab-pointer ungrab-server uninstall-colormap unknown-error unmap-subwindows unmap-window value-error visual-info visual-info-bits-per-rgb visual-info-blue-mask visual-info-class visual-info-colormap-entries visual-info-display visual-info-green-mask visual-info-id visual-info-p visual-info-plist visual-info-red-mask warp-pointer warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside win-gravity window window-all-event-masks window-background window-backing-pixel window-backing-planes window-backing-store window-bit-gravity window-border window-class window-colormap window-colormap-installed-p window-cursor window-display window-do-not-propagate-mask window-equal window-error window-event-mask window-gravity window-id window-map-state window-override-redirect window-p window-plist window-priority window-save-under window-visual window-visual-info with-display with-event-queue with-gcontext with-server-grabbed with-state withdraw-window wm-client-machine wm-colormap-windows wm-command wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources wm-size-hints wm-size-hints-base-height wm-size-hints-base-width wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file write-resources xatom )) ;;; The ANSI Common Lisp way #+(and Genera clx-ansi-common-lisp) (eval-when (:compile-toplevel :load-toplevel :execute) (setf *readtable* si:*ansi-common-lisp-readtable*)) #+clx-ansi-common-lisp (common-lisp:in-package :common-lisp-user) #+clx-ansi-common-lisp (defpackage xlib (:use common-lisp) (:size 3000) #+(or kcl ibcl) (:shadow rational) #+allegro (:use cltl1) #+allegro (:import-from excl without-interrupts) #+excl (:import-from excl arglist) #+Genera (:import-from zwei indentation) #+lcl3.0 (:import-from lcl arglist) #+lispm (:import-from lisp char-bit) #+lispm (:import-from sys arglist with-stack-list with-stack-list*) #+sbcl (:use sb-bsd-sockets) (:export *version* access-control access-error access-hosts activate-screen-saver add-access-host add-resource add-to-save-set alist alloc-color alloc-color-cells alloc-color-planes alloc-error allow-events angle arc-seq array-index atom-error atom-name bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image boole-constant boolean card16 card29 card32 card8 card8->char change-active-pointer-grab change-keyboard-control change-keyboard-mapping change-pointer-control change-property char->card8 char-ascent char-attributes char-descent char-left-bearing char-right-bearing char-width character->keysyms character-in-map-p circulate-window-down circulate-window-up clear-area close-display close-down-mode close-font closed-display color color-blue color-green color-p color-red color-rgb colormap colormap-display colormap-equal colormap-error colormap-id colormap-p colormap-plist colormap-visual-info connection-failure convert-selection copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components copy-image copy-plane create-colormap create-cursor create-gcontext create-glyph-cursor create-image create-pixmap create-window cursor cursor-display cursor-equal cursor-error cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error default-error-handler default-keysym-index default-keysym-translate define-error define-extension define-gcontext-accessor define-keysym define-keysym-set delete-property delete-resource destroy-subwindows destroy-window device-busy device-event-mask device-event-mask-class discard-current-event discard-font-info display display-after-function display-authorization-data display-authorization-name display-bitmap-format display-byte-order display-default-screen display-display display-error-handler display-extended-max-request-length display-finish-output display-force-output display-host display-image-lsb-first-p display-invoke-after-function display-keycode-range display-max-keycode display-max-request-length display-min-keycode display-motion-buffer-size display-nscreens display-p display-pixmap-formats display-plist display-protocol-major-version display-protocol-minor-version display-protocol-version display-release-number display-report-asynchronous-errors display-resource-id-base display-resource-id-mask display-roots display-vendor display-vendor-name display-xdefaults display-xid draw-arc draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph draw-image-glyphs draw-line draw-lines draw-point draw-points draw-rectangle draw-rectangles draw-segments drawable drawable-border-width drawable-depth drawable-display drawable-equal drawable-error drawable-height drawable-id drawable-p drawable-plist drawable-root drawable-width drawable-x drawable-y error-key event-case event-cond event-handler event-key event-listen event-mask event-mask-class extension-opcode find-atom font font-all-chars-exist-p font-ascent font-default-char font-descent font-direction font-display font-equal font-error font-id font-max-byte1 font-max-byte2 font-max-char font-min-byte1 font-min-byte2 font-min-char font-name font-p font-path font-plist font-properties font-property fontable force-gcontext-changes free-colormap free-colors free-cursor free-gcontext free-pixmap gcontext gcontext-arc-mode gcontext-background gcontext-cache-p gcontext-cap-style gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule gcontext-fill-style gcontext-font gcontext-foreground gcontext-function gcontext-id gcontext-join-style gcontext-key gcontext-line-style gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x gcontext-ts-y generalized-boolean get-external-event-code get-image get-property get-raw-image get-resource get-search-resource get-search-table get-standard-colormap get-wm-class global-pointer-position grab-button grab-key grab-keyboard grab-pointer grab-server grab-status icon-sizes iconify-window id-choice-error illegal-request-error image image-blue-mask image-depth image-green-mask image-height image-name image-pixmap image-plist image-red-mask image-width image-x image-x-hot image-x-p image-xy image-xy-bitmap-list image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p image-z-pixarray implementation-error input-focus install-colormap installed-colormaps int16 int32 int8 intern-atom invalid-font keyboard-control keyboard-mapping keycode->character keycode->keysym keysym keysym->character keysym->keycodes keysym-in-map-p keysym-set kill-client kill-temporary-clients length-error list-extensions list-font-names list-fonts list-properties lookup-color lookup-error make-color make-event-handlers make-event-keys make-event-mask make-resource-database make-state-keys make-state-mask make-wm-hints make-wm-size-hints map-resource map-subwindows map-window mapping-notify mask16 mask32 match-error max-char-ascent max-char-attributes max-char-descent max-char-left-bearing max-char-right-bearing max-char-width merge-resources min-char-ascent min-char-attributes min-char-descent min-char-left-bearing min-char-right-bearing min-char-width missing-parameter modifier-key modifier-mapping modifier-mask motion-events name-error no-operation open-default-display open-display open-font pixarray pixel pixmap pixmap-display pixmap-equal pixmap-error pixmap-format pixmap-format-bits-per-pixel pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad pixmap-id pixmap-p pixmap-plist point-seq pointer-control pointer-event-mask pointer-event-mask-class pointer-mapping pointer-position process-event put-image put-raw-image query-best-cursor query-best-stipple query-best-tile query-colors query-extension query-keymap query-pointer query-tree queue-event read-bitmap-file read-resources recolor-cursor rect-seq remove-access-host remove-from-save-set reparent-window repeat-seq reply-length-error reply-timeout request-error reset-screen-saver resource-database resource-database-timestamp resource-error resource-id resource-key rgb-colormaps rgb-val root-resources rotate-cut-buffers rotate-properties screen screen-backing-stores screen-black-pixel screen-default-colormap screen-depths screen-event-mask-at-open screen-height screen-height-in-millimeters screen-max-installed-maps screen-min-installed-maps screen-p screen-plist screen-root screen-root-depth screen-root-visual screen-root-visual-info screen-save-unders-p screen-saver screen-white-pixel screen-width screen-width-in-millimeters seg-seq selection-owner send-event sequence-error set-access-control set-close-down-mode set-input-focus set-modifier-mapping set-pointer-mapping set-screen-saver set-selection-owner set-standard-colormap set-standard-properties set-wm-class set-wm-properties set-wm-resources state-keysym-p state-mask-key store-color store-colors stringable text-extents text-width timestamp transient-for translate-coordinates translate-default translation-function undefine-keysym unexpected-reply ungrab-button ungrab-key ungrab-keyboard ungrab-pointer ungrab-server uninstall-colormap unknown-error unmap-subwindows unmap-window value-error visual-info visual-info-bits-per-rgb visual-info-blue-mask visual-info-class visual-info-colormap-entries visual-info-display visual-info-green-mask visual-info-id visual-info-p visual-info-plist visual-info-red-mask warp-pointer warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside win-gravity window window-all-event-masks window-background window-backing-pixel window-backing-planes window-backing-store window-bit-gravity window-border window-class window-colormap window-colormap-installed-p window-cursor window-display window-do-not-propagate-mask window-equal window-error window-event-mask window-gravity window-id window-map-state window-override-redirect window-p window-plist window-priority window-save-under window-visual window-visual-info with-display with-event-queue with-gcontext with-server-grabbed with-state withdraw-window wm-client-machine wm-colormap-windows wm-command wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources wm-size-hints wm-size-hints-base-height wm-size-hints-base-width wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file write-resources xatom) ;; Exports from xvidmode.lisp (:export mode-info mode-info-dotclock mode-info-hdisplay mode-info-hsyncstart mode-info-hsyncend mode-info-htotal mode-info-hskew mode-info-vdisplay mode-info-vsyncstart mode-info-vsyncend mode-info-vtotal mode-info-flags mode-info-privsize mode-info-private make-mode-info xfree86-vidmode-query-version xfree86-vidmode-set-client-version xfree86-vidmode-get-permissions xfree86-vidmode-mod-mode-line xfree86-vidmode-get-mode-line xfree86-vidmode-get-all-mode-lines xfree86-vidmode-add-mode-line xfree86-vidmode-delete-mode-line xfree86-vidmode-validate-mode-line xfree86-vidmode-get-gamma xfree86-vidmode-set-gamma xfree86-vidmode-get-gamma-ramp xfree86-vidmode-set-gamma-ramp xfree86-vidmode-get-gamma-ramp-size xfree86-vidmode-lock-mode-switch xfree86-vidmode-switch-to-mode xfree86-vidmode-switch-mode xfree86-vidmode-select-next-mode xfree86-vidmode-select-prev-mode xfree86-vidmode-get-monitor xfree86-vidmode-get-viewport xfree86-vidmode-set-viewport xfree86-vidmode-get-dotclocks) ;; xrender (:export render-create-picture render-free-picture render-create-glyph-set render-reference-glyph-set render-free-glyph-set render-add-glyph render-add-glyph-from-picture render-free-glyph render-fill-rectangle picture-format-display picture-format-id picture-format-type picture-format-depth picture-format-red-byte picture-format-green-byte picture-format-blue-byte picture-format-alpha-byte picture-format-colormap ;; picture object picture-repeat picture-alpha-map picture-alpha-x-origin picture-alpha-y-origin picture-clip-x-origin picture-clip-y-origin picture-clip-mask picture-graphics-exposures picture-subwindow-mode picture-poly-edge picture-poly-mode picture-dither picture-component-alpha picture-drawable find-matching-picture-formats find-window-picture-format render-free-picture render-free-glyph-set render-query-version ;; render-query-picture-formats render-fill-rectangle render-composite render-create-glyph-set render-reference-glyph-set render-composite-glyphs render-add-glyph render-add-glyph-from-picture render-free-glyphs render-combine) ;; Shape extension (:export shape-query-version shape-rectangles shape-mask shape-combine shape-offset shape-query-extents shape-select-input shape-input-selected-p shape-get-rectangles)) cmucl-21a/src/clx/provide.lisp000066400000000000000000000032371260377556400165040ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- ;;;; Module definition for CLX ;;; This file is a Common Lisp Module description, but you will have to edit ;;; it to meet the needs of your site. ;;; Ideally, this file (or a file that loads this file) should be ;;; located in the system directory that REQUIRE searches. Thus a user ;;; would say ;;; (require :clx) ;;; to load CLX. If there is no such registry, then the user must ;;; put in a site specific ;;; (require :clx ) ;;; #+cmu (ext:file-comment "$Id: provide.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $") #+cmu (cl:provide "CLX") #-cmu (progn #-clx-ansi-common-lisp (in-package :user) #+clx-ansi-common-lisp (in-package :common-lisp-user) #-clx-ansi-common-lisp (provide :clx) (defvar *clx-source-pathname* (pathname "/src/local/clx/*.l")) (defvar *clx-binary-pathname* (let ((lisp (or #+lucid "lucid" #+akcl "akcl" #+kcl "kcl" #+ibcl "ibcl" (error "Can't provide CLX for this lisp."))) (architecture (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" #+(or sun4 sparc) "sparc" #+(and hp (or mc68000 mc68020)) "hp9000s300" #+vax "vax" #+prime "prime" #+sunrise "sunrise" #+ibm-rt-pc "ibm-rt-pc" #+mips "mips" #+prism "prism" (error "Can't provide CLX for this architecture.")))) (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) (defvar *compile-clx* nil) (load (merge-pathnames "defsystem" *clx-source-pathname*)) (if *compile-clx* (compile-clx *clx-source-pathname* *clx-binary-pathname*) (load-clx *clx-binary-pathname*)) ) cmucl-21a/src/clx/requests.lisp000066400000000000000000001540771260377556400167200ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: requests.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defun create-window (&key window (parent (required-arg parent)) (x (required-arg x)) (y (required-arg y)) (width (required-arg width)) (height (required-arg height)) (depth 0) (border-width 0) (class :copy) (visual :copy) background border bit-gravity gravity backing-store backing-planes backing-pixel save-under event-mask do-not-propagate-mask override-redirect colormap cursor) ;; Display is obtained from parent. Only non-nil attributes are passed on in ;; the request: the function makes no assumptions about what the actual protocol ;; defaults are. Width and height are the inside size, excluding border. (declare (type (or null window) window) (type window parent) ; required (type int16 x y) ;required (type card16 width height) ;required (type card16 depth border-width) (type (member :copy :input-output :input-only) class) (type (or (member :copy) visual-info resource-id) visual) (type (or null (member :none :parent-relative) pixel pixmap) background) (type (or null (member :copy) pixel pixmap) border) (type (or null bit-gravity) bit-gravity) (type (or null win-gravity) gravity) (type (or null (member :not-useful :when-mapped :always)) backing-store) (type (or null pixel) backing-planes backing-pixel) (type (or null event-mask) event-mask) (type (or null device-event-mask) do-not-propagate-mask) (type (or null (member :on :off)) save-under override-redirect) (type (or null (member :copy) colormap) colormap) (type (or null (member :none) cursor) cursor)) (declare (clx-values window)) (let* ((display (window-display parent)) (window (or window (make-window :display display))) (wid (allocate-resource-id display window 'window)) back-pixmap back-pixel border-pixmap border-pixel) (declare (type display display) (type window window) (type resource-id wid) (type (or null resource-id) back-pixmap border-pixmap) (type (or null pixel) back-pixel border-pixel)) (setf (window-id window) wid) (case background ((nil) nil) (:none (setq back-pixmap 0)) (:parent-relative (setq back-pixmap 1)) (otherwise (if (type? background 'pixmap) (setq back-pixmap (pixmap-id background)) (if (integerp background) (setq back-pixel background) (x-type-error background '(or null (member :none :parent-relative) integer pixmap)))))) (case border ((nil) nil) (:copy (setq border-pixmap 0)) (otherwise (if (type? border 'pixmap) (setq border-pixmap (pixmap-id border)) (if (integerp border) (setq border-pixel border) (x-type-error border '(or null (member :copy) integer pixmap)))))) (when event-mask (setq event-mask (encode-event-mask event-mask))) (when do-not-propagate-mask (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask))) ;Make the request (with-buffer-request (display +x-createwindow+) (data depth) (resource-id wid) (window parent) (int16 x y) (card16 width height border-width) ((member16 :copy :input-output :input-only) class) (resource-id (cond ((eq visual :copy) 0) ((typep visual 'resource-id) visual) (t (visual-info-id visual)))) (mask (card32 back-pixmap back-pixel border-pixmap border-pixel) ((member-vector +bit-gravity-vector+) bit-gravity) ((member-vector +win-gravity-vector+) gravity) ((member :not-useful :when-mapped :always) backing-store) (card32 backing-planes backing-pixel) ((member :off :on) override-redirect save-under) (card32 event-mask do-not-propagate-mask) ((or (member :copy) colormap) colormap) ((or (member :none) cursor) cursor))) window)) (defun destroy-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-destroywindow+) (window window))) (defun destroy-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-destroysubwindows+) (window window))) (defun add-to-save-set (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-changesaveset+) (data 0) (window window))) (defun remove-from-save-set (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-changesaveset+) (data 1) (window window))) (defun reparent-window (window parent x y) (declare (type window window parent) (type int16 x y)) (with-buffer-request ((window-display window) +x-reparentwindow+) (window window parent) (int16 x y))) (defun map-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-mapwindow+) (window window))) (defun map-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-mapsubwindows+) (window window))) (defun unmap-window (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-unmapwindow+) (window window))) (defun unmap-subwindows (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-unmapsubwindows+) (window window))) (defun circulate-window-up (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-circulatewindow+) (data 0) (window window))) (defun circulate-window-down (window) (declare (type window window)) (with-buffer-request ((window-display window) +x-circulatewindow+) (data 1) (window window))) (defun query-tree (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;;type specifier (declare (clx-values (clx-sequence window) parent root)) (let ((display (window-display window))) (multiple-value-bind (root parent sequence) (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32)) ((window window)) (values (window-get 8) (resource-id-get 12) (sequence-get :length (card16-get 16) :result-type result-type :index +replysize+))) ;; Parent is NIL for root window (setq parent (and (plusp parent) (lookup-window display parent))) (dotimes (i (length sequence)) ; Convert ID's to window's (setf (elt sequence i) (lookup-window display (elt sequence i)))) (values sequence parent root)))) ;; Although atom-ids are not visible in the normal user interface, atom-ids might ;; appear in window properties and other user data, so conversion hooks are needed. (defun intern-atom (display name) (declare (type display display) (type xatom name)) (declare (clx-values resource-id)) (let ((name (if (or (null name) (keywordp name)) name (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 0) (card16 (length string)) (pad16 nil) (string string)) (values (resource-id-get 8))) (declare (type resource-id id)) (setf (atom-id name display) id) id))))) (defun find-atom (display name) ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True (declare (type display display) (type xatom name)) (declare (clx-values (or null resource-id))) (let ((name (if (or (null name) (keywordp name)) name (kintern (string name))))) (declare (type symbol name)) (or (atom-id name display) (let ((string (symbol-name name))) (declare (type string string)) (multiple-value-bind (id) (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32) ((data 1) (card16 (length string)) (pad16 nil) (string string)) (values (or-get 8 null resource-id))) (declare (type (or null resource-id) id)) (when id (setf (atom-id name display) id)) id))))) (defun atom-name (display atom-id) (declare (type display display) (type resource-id atom-id)) (declare (clx-values keyword)) (if (zerop atom-id) nil (or (id-atom atom-id display) (let ((keyword (kintern (with-buffer-request-and-reply (display +x-getatomname+ nil :sizes (16)) ((resource-id atom-id)) (values (string-get (card16-get 8) +replysize+)))))) (declare (type keyword keyword)) (setf (atom-id keyword display) atom-id) keyword)))) ;;; For binary compatibility with older code (defun lookup-xatom (display atom-id) (declare (type display display) (type resource-id atom-id)) (atom-name display atom-id)) (defun change-property (window property data type format &key (mode :replace) (start 0) end transform) ; Start and end affect sub-sequence extracted from data. ; Transform is applied to each extracted element. (declare (type window window) (type xatom property type) (type (member 8 16 32) format) (type sequence data) (type (member :replace :prepend :append) mode) (type array-index start) (type (or null array-index) end) (type (or null (function (t) integer)) transform)) (unless end (setq end (length data))) (let* ((display (window-display window)) (length (index- end start)) (property-id (intern-atom display property)) (type-id (intern-atom display type))) (declare (type display display) (type array-index length) (type resource-id property-id type-id)) (with-buffer-request (display +x-changeproperty+) ((data (member :replace :prepend :append)) mode) (window window) (resource-id property-id type-id) (card8 format) (card32 length) (progn (ecase format (8 (sequence-put 24 data :format card8 :start start :end end :transform transform)) (16 (sequence-put 24 data :format card16 :start start :end end :transform transform)) (32 (sequence-put 24 data :format card32 :start start :end end :transform transform))))))) (defun delete-property (window property) (declare (type window window) (type xatom property)) (let* ((display (window-display window)) (property-id (intern-atom display property))) (declare (type display display) (type resource-id property-id)) (with-buffer-request (display +x-deleteproperty+) (window window) (resource-id property-id)))) (defun get-property (window property &key type (start 0) end delete-p (result-type 'list) transform) ;; Transform is applied to each integer retrieved. (declare (type window window) (type xatom property) (type (or null xatom) type) (type array-index start) (type (or null array-index) end) (type generalized-boolean delete-p) (type t result-type) ;a sequence type (type (or null (function (integer) t)) transform)) (declare (clx-values data (or null type) format bytes-after)) (let* ((display (window-display window)) (property-id (intern-atom display property)) (type-id (and type (intern-atom display type)))) (declare (type display display) (type resource-id property-id) (type (or null resource-id) type-id)) (multiple-value-bind (reply-format reply-type bytes-after data) (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32)) (((data boolean) delete-p) (window window) (resource-id property-id) ((or null resource-id) type-id) (card32 start) (card32 (index- (or end 64000) start))) (let ((reply-format (card8-get 1)) (reply-type (card32-get 8)) (bytes-after (card32-get 12)) (nitems (card32-get 16))) (values reply-format reply-type bytes-after (and (plusp nitems) (ecase reply-format (0 nil) ;; (make-sequence result-type 0) ;; Property not found. (8 (sequence-get :result-type result-type :format card8 :length nitems :transform transform :index +replysize+)) (16 (sequence-get :result-type result-type :format card16 :length nitems :transform transform :index +replysize+)) (32 (sequence-get :result-type result-type :format card32 :length nitems :transform transform :index +replysize+))))))) (values data (and (plusp reply-type) (atom-name display reply-type)) reply-format bytes-after)))) (defun rotate-properties (window properties &optional (delta 1)) ;; Positive rotates left, negative rotates right (opposite of actual protocol request). (declare (type window window) (type sequence properties) ;; sequence of xatom (type int16 delta)) (let* ((display (window-display window)) (length (length properties)) (sequence (make-array length))) (declare (type display display) (type array-index length)) (with-vector (sequence vector) ;; Atoms must be interned before the RotateProperties request ;; is started to allow InternAtom requests to be made. (dotimes (i length) (setf (aref sequence i) (intern-atom display (elt properties i)))) (with-buffer-request (display +x-rotateproperties+) (window window) (card16 length) (int16 (- delta)) ((sequence :end length) sequence)))) nil) (defun list-properties (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;; a sequence type (declare (clx-values (clx-sequence keyword))) (let ((display (window-display window))) (multiple-value-bind (seq) (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+))) ;; lookup the atoms in the sequence (if (listp seq) (do ((elt seq (cdr elt))) ((endp elt) seq) (setf (car elt) (atom-name display (car elt)))) (dotimes (i (length seq) seq) (setf (aref seq i) (atom-name display (aref seq i)))))))) (defun selection-owner (display selection) (declare (type display display) (type xatom selection)) (declare (clx-values (or null window))) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (multiple-value-bind (window) (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32) ((resource-id selection-id)) (values (resource-id-or-nil-get 8))) (and window (lookup-window display window))))) (defun set-selection-owner (display selection owner &optional time) (declare (type display display) (type xatom selection) (type (or null window) owner) (type timestamp time)) (let ((selection-id (intern-atom display selection))) (declare (type resource-id selection-id)) (with-buffer-request (display +x-setselectionowner+) ((or null window) owner) (resource-id selection-id) ((or null card32) time)) owner)) (defsetf selection-owner (display selection &optional time) (owner) ;; A bit strange, but retains setf form. `(set-selection-owner ,display ,selection ,owner ,time)) (defun convert-selection (selection type requestor &optional property time) (declare (type xatom selection type) (type window requestor) (type (or null xatom) property) (type timestamp time)) (let* ((display (window-display requestor)) (selection-id (intern-atom display selection)) (type-id (intern-atom display type)) (property-id (and property (intern-atom display property)))) (declare (type display display) (type resource-id selection-id type-id) (type (or null resource-id) property-id)) (with-buffer-request (display +x-convertselection+) (window requestor) (resource-id selection-id type-id) ((or null resource-id) property-id) ((or null card32) time)))) (defun send-event (window event-key event-mask &rest args &key propagate-p display &allow-other-keys) ;; Additional arguments depend on event-key, and are as specified further below ;; with declare-event, except that both resource-ids and resource objects are ;; accepted in the event components. The display argument is only required if the ;; window is :pointer-window or :input-focus. (declare (type (or window (member :pointer-window :input-focus)) window) (type event-key event-key) (type (or null event-mask) event-mask) (type generalized-boolean propagate-p) (type (or null display) display) (dynamic-extent args)) (unless event-mask (setq event-mask 0)) (unless display (setq display (window-display window))) (let ((internal-event-code (get-event-code event-key)) (external-event-code (get-external-event-code display event-key))) (declare (type card8 internal-event-code external-event-code)) ;; Ensure keyword atom-id's are cached (dolist (arg (cdr (assoc event-key '((:property-notify :atom) (:selection-clear :selection) (:selection-request :selection :target :property) (:selection-notify :selection :target :property) (:client-message :type)) :test #'eq))) (let ((keyword (getf args arg))) (intern-atom display keyword))) ;; Make the sendevent request (with-buffer-request (display +x-sendevent+) ((data boolean) propagate-p) (length 11) ;; 3 word request + 8 words for event = 11 ((or (member :pointer-window :input-focus) window) window) (card32 (encode-event-mask event-mask)) (card8 external-event-code) (progn (apply (svref *event-send-vector* internal-event-code) display args) (setf (buffer-boffset display) (index+ buffer-boffset 44)))))) (defun grab-pointer (window event-mask &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time) (declare (type window window) (type pointer-event-mask event-mask) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor) (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8) (((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) (boolean (not sync-pointer-p) (not sync-keyboard-p)) ((or null window) confine-to) ((or null cursor) cursor) ((or null card32) time)) (values (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-pointer (display &key time) (declare (type timestamp time)) (with-buffer-request (display +x-ungrabpointer+) ((or null card32) time))) (defun grab-button (window button event-mask &key (modifiers :any) owner-p sync-pointer-p sync-keyboard-p confine-to cursor) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers) (type pointer-event-mask event-mask) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or null window) confine-to) (type (or null cursor) cursor)) (with-buffer-request ((window-display window) +x-grabbutton+) ((data boolean) owner-p) (window window) (card16 (encode-pointer-event-mask event-mask)) (boolean (not sync-pointer-p) (not sync-keyboard-p)) ((or null window) confine-to) ((or null cursor) cursor) (card8 (if (eq button :any) 0 button)) (pad8 1) (card16 (encode-modifier-mask modifiers)))) (defun ungrab-button (window button &key (modifiers :any)) (declare (type window window) (type (or (member :any) card8) button) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabbutton+) (data (if (eq button :any) 0 button)) (window window) (card16 (encode-modifier-mask modifiers)))) (defun change-active-pointer-grab (display event-mask &optional cursor time) (declare (type display display) (type pointer-event-mask event-mask) (type (or null cursor) cursor) (type timestamp time)) (with-buffer-request (display +x-changeactivepointergrab+) ((or null cursor) cursor) ((or null card32) time) (card16 (encode-pointer-event-mask event-mask)))) (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time) (declare (type window window) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type timestamp time)) (declare (clx-values grab-status)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8) (((data boolean) owner-p) (window window) ((or null card32) time) (boolean (not sync-pointer-p) (not sync-keyboard-p))) (values (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen))))) (defun ungrab-keyboard (display &key time) (declare (type display display) (type timestamp time)) (with-buffer-request (display +x-ungrabkeyboard+) ((or null card32) time))) (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p) (declare (type window window) (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p) (type (or (member :any) card8) key) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-grabkey+) ((data boolean) owner-p) (window window) (card16 (encode-modifier-mask modifiers)) (card8 (if (eq key :any) 0 key)) (boolean (not sync-pointer-p) (not sync-keyboard-p)))) (defun ungrab-key (window key &key (modifiers 0)) (declare (type window window) (type (or (member :any) card8) key) (type modifier-mask modifiers)) (with-buffer-request ((window-display window) +x-ungrabkey+) (data (if (eq key :any) 0 key)) (window window) (card16 (encode-modifier-mask modifiers)))) (defun allow-events (display mode &optional time) (declare (type display display) (type (member :async-pointer :sync-pointer :replay-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both) mode) (type timestamp time)) (with-buffer-request (display +x-allowevents+) ((data (member :async-pointer :sync-pointer :replay-pointer :async-keyboard :sync-keyboard :replay-keyboard :async-both :sync-both)) mode) ((or null card32) time))) (defun grab-server (display) (declare (type display display)) (with-buffer-request (display +x-grabserver+))) (defun ungrab-server (display) (with-buffer-request (display +x-ungrabserver+))) (defmacro with-server-grabbed ((display) &body body) ;; The body is not surrounded by a with-display. (let ((disp (if (symbolp display) display (gensym)))) `(let ((,disp ,display)) (declare (type display ,disp)) (unwind-protect (progn (grab-server ,disp) ,@body) (ungrab-server ,disp))))) (defun query-pointer (window) (declare (type window window)) (declare (clx-values x y same-screen-p child mask root-x root-y root)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32)) ((window window)) (values (int16-get 20) (int16-get 22) (boolean-get 1) (or-get 12 null window) (card16-get 24) (int16-get 16) (int16-get 18) (window-get 8))))) (defun pointer-position (window) (declare (type window window)) (declare (clx-values x y same-screen-p)) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16)) ((window window)) (values (int16-get 20) (int16-get 22) (boolean-get 1))))) (defun global-pointer-position (display) (declare (type display display)) (declare (clx-values root-x root-y root)) (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32)) ((window (screen-root (first (display-roots display))))) (values (int16-get 16) (int16-get 18) (window-get 8)))) (defun motion-events (window &key start stop (result-type 'list)) (declare (type window window) (type timestamp start stop) (type t result-type)) ;; a type specifier (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time)))) (let ((display (window-display window))) (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32) ((window window) ((or null card32) start stop)) (values (sequence-get :result-type result-type :length (index* (card32-get 8) 3) :index +replysize+))))) (defun translate-coordinates (src src-x src-y dst) ;; Returns NIL when not on the same screen (declare (type window src) (type int16 src-x src-y) (type window dst)) (declare (clx-values dst-x dst-y child)) (let ((display (window-display src))) (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32)) ((window src dst) (int16 src-x src-y)) (and (boolean-get 1) (values (int16-get 12) (int16-get 14) (or-get 8 null window)))))) (defun warp-pointer (dst dst-x dst-y) (declare (type window dst) (type int16 dst-x dst-y)) (with-buffer-request ((window-display dst) +x-warppointer+) (resource-id 0) ;; None (window dst) (int16 0 0) (card16 0 0) (int16 dst-x dst-y))) (defun warp-pointer-relative (display x-off y-off) (declare (type display display) (type int16 x-off y-off)) (with-buffer-request (display +x-warppointer+) (resource-id 0) ;; None (resource-id 0) ;; None (int16 0 0) (card16 0 0) (int16 x-off y-off))) (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window dst src) (type int16 dst-x dst-y src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display dst) +x-warppointer+) (window src dst) (int16 src-x src-y) (card16 (or src-width 0) (or src-height 0)) (int16 dst-x dst-y)))) (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y &optional src-width src-height) ;; Passing in a zero src-width or src-height is a no-op. ;; A null src-width or src-height translates into a zero value in the protocol request. (declare (type window src) (type int16 x-off y-off src-x src-y) (type (or null card16) src-width src-height)) (unless (or (eql src-width 0) (eql src-height 0)) (with-buffer-request ((window-display src) +x-warppointer+) (window src) (resource-id 0) ;; None (int16 src-x src-y) (card16 (or src-width 0) (or src-height 0)) (int16 x-off y-off)))) (defun set-input-focus (display focus revert-to &optional time) (declare (type display display) (type (or (member :none :pointer-root) window) focus) (type (member :none :pointer-root :parent) revert-to) (type timestamp time)) (with-buffer-request (display +x-setinputfocus+) ((data (member :none :pointer-root :parent)) revert-to) ((or window (member :none :pointer-root)) focus) ((or null card32) time))) (defun input-focus (display) (declare (type display display)) (declare (clx-values focus revert-to)) (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32)) () (values (or-get 8 window (member :none :pointer-root)) (member8-get 1 :none :pointer-root :parent)))) (defun query-keymap (display &optional bit-vector) (declare (type display display) (type (or null (bit-vector 256)) bit-vector)) (declare (clx-values (bit-vector 256))) (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8) () (values (bit-vector256-get 8 8 bit-vector)))) (defun create-pixmap (&key pixmap (width (required-arg width)) (height (required-arg height)) (depth (required-arg depth)) (drawable (required-arg drawable))) (declare (type (or null pixmap) pixmap) (type card8 depth) ;; required (type card16 width height) ;; required (type drawable drawable)) ;; required (declare (clx-values pixmap)) (let* ((display (drawable-display drawable)) (pixmap (or pixmap (make-pixmap :display display))) (pid (allocate-resource-id display pixmap 'pixmap))) (setf (pixmap-id pixmap) pid) (with-buffer-request (display +x-createpixmap+) (data depth) (resource-id pid) (drawable drawable) (card16 width height)) pixmap)) (defun free-pixmap (pixmap) (declare (type pixmap pixmap)) (let ((display (pixmap-display pixmap))) (with-buffer-request (display +x-freepixmap+) (pixmap pixmap)) (deallocate-resource-id display (pixmap-id pixmap) 'pixmap))) (defun clear-area (window &key (x 0) (y 0) width height exposures-p) ;; Passing in a zero width or height is a no-op. ;; A null width or height translates into a zero value in the protocol request. (declare (type window window) (type int16 x y) (type (or null card16) width height) (type generalized-boolean exposures-p)) (unless (or (eql width 0) (eql height 0)) (with-buffer-request ((window-display window) +x-cleartobackground+) ((data boolean) exposures-p) (window window) (int16 x y) (card16 (or width 0) (or height 0))))) (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) (card16 width height))) (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y) (declare (type drawable src dst) (type gcontext gcontext) (type pixel plane) (type int16 src-x src-y dst-x dst-y) (type card16 width height)) (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext) (drawable src dst) (gcontext gcontext) (int16 src-x src-y dst-x dst-y) (card16 width height) (card32 plane))) (defun create-colormap (visual-info window &optional alloc-p) (declare (type (or visual-info resource-id) visual-info) (type window window) (type generalized-boolean alloc-p)) (declare (clx-values colormap)) (let ((display (window-display window))) (when (typep visual-info 'resource-id) (setf visual-info (visual-info display visual-info))) (let* ((colormap (make-colormap :display display :visual-info visual-info)) (id (allocate-resource-id display colormap 'colormap))) (setf (colormap-id colormap) id) (with-buffer-request (display +x-createcolormap+) ((data boolean) alloc-p) (card29 id) (window window) (card29 (visual-info-id visual-info))) colormap))) (defun free-colormap (colormap) (declare (type colormap colormap)) (let ((display (colormap-display colormap))) (with-buffer-request (display +x-freecolormap+) (colormap colormap)) (deallocate-resource-id display (colormap-id colormap) 'colormap))) (defun copy-colormap-and-free (colormap) (declare (type colormap colormap)) (declare (clx-values colormap)) (let* ((display (colormap-display colormap)) (new-colormap (make-colormap :display display :visual-info (colormap-visual-info colormap))) (id (allocate-resource-id display new-colormap 'colormap))) (setf (colormap-id new-colormap) id) (with-buffer-request (display +x-copycolormapandfree+) (resource-id id) (colormap colormap)) new-colormap)) (defun install-colormap (colormap) (declare (type colormap colormap)) (with-buffer-request ((colormap-display colormap) +x-installcolormap+) (colormap colormap))) (defun uninstall-colormap (colormap) (declare (type colormap colormap)) (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+) (colormap colormap))) (defun installed-colormaps (window &key (result-type 'list)) (declare (type window window) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence colormap))) (let ((display (window-display window))) (flet ((get-colormap (id) (lookup-colormap display id))) (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16) ((window window)) (values (sequence-get :result-type result-type :length (card16-get 8) :transform #'get-colormap :index +replysize+)))))) (defun alloc-color (colormap color) (declare (type colormap colormap) (type (or stringable color) color)) (declare (clx-values pixel screen-color exact-color)) (let ((display (colormap-display colormap))) (etypecase color (color (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32)) ((colormap colormap) (rgb-val (color-red color) (color-green color) (color-blue color)) (pad16 nil)) (values (card32-get 16) (make-color :red (rgb-val-get 8) :green (rgb-val-get 10) :blue (rgb-val-get 12)) color))) (stringable (let* ((string (string color)) (length (length string))) (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32)) ((colormap colormap) (card16 length) (pad16 nil) (string string)) (values (card32-get 8) (make-color :red (rgb-val-get 18) :green (rgb-val-get 20) :blue (rgb-val-get 22)) (make-color :red (rgb-val-get 12) :green (rgb-val-get 14) :blue (rgb-val-get 16))))))))) (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors planes) (type generalized-boolean contiguous-p) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) (clx-sequence mask))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16) (((data boolean) contiguous-p) (colormap colormap) (card16 colors planes)) (let ((pixel-length (card16-get 8)) (mask-length (card16-get 10))) (values (sequence-get :result-type result-type :length pixel-length :index +replysize+) (sequence-get :result-type result-type :length mask-length :index (index+ +replysize+ (index* pixel-length 4)))))))) (defun alloc-color-planes (colormap colors &key (reds 0) (greens 0) (blues 0) contiguous-p (result-type 'list)) (declare (type colormap colormap) (type card16 colors reds greens blues) (type generalized-boolean contiguous-p) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32)) (((data boolean) contiguous-p) (colormap colormap) (card16 colors reds greens blues)) (let ((red-mask (card32-get 12)) (green-mask (card32-get 16)) (blue-mask (card32-get 20))) (values (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+) red-mask green-mask blue-mask))))) (defun free-colors (colormap pixels &optional (plane-mask 0)) (declare (type colormap colormap) (type sequence pixels) ;; Sequence of integers (type pixel plane-mask)) (with-buffer-request ((colormap-display colormap) +x-freecolors+) (colormap colormap) (card32 plane-mask) (sequence pixels))) (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t)) (declare (type colormap colormap) (type pixel pixel) (type (or stringable color) spec) (type generalized-boolean red-p green-p blue-p)) (let ((display (colormap-display colormap)) (flags 0)) (declare (type display display) (type card8 flags)) (when red-p (setq flags 1)) (when green-p (incf flags 2)) (when blue-p (incf flags 4)) (etypecase spec (color (with-buffer-request (display +x-storecolors+) (colormap colormap) (card32 pixel) (rgb-val (color-red spec) (color-green spec) (color-blue spec)) (card8 flags) (pad8 nil))) (stringable (let* ((string (string spec)) (length (length string))) (with-buffer-request (display +x-storenamedcolor+) ((data card8) flags) (colormap colormap) (card32 pixel) (card16 length) (pad16 nil) (string string))))))) (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t)) ;; If stringables are specified for colors, it is unspecified whether all ;; stringables are first resolved and then a single StoreColors protocol request is ;; issued, or whether multiple StoreColors protocol requests are issued. (declare (type colormap colormap) (type sequence specs) (type generalized-boolean red-p green-p blue-p)) (etypecase specs (list (do ((spec specs (cddr spec))) ((endp spec)) (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p))) (vector (do ((i 0 (+ i 2)) (len (length specs))) ((>= i len)) (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p))))) (defun query-colors (colormap pixels &key (result-type 'list)) (declare (type colormap colormap) (type sequence pixels) ;; sequence of integer (type t result-type)) ;; a type specifier (declare (clx-values (clx-sequence color))) (let ((display (colormap-display colormap))) (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16)) ((colormap colormap) (sequence pixels)) (let ((sequence (make-sequence result-type (card16-get 8)))) (advance-buffer-offset +replysize+) (dotimes (i (length sequence) sequence) (setf (elt sequence i) (make-color :red (rgb-val-get 0) :green (rgb-val-get 2) :blue (rgb-val-get 4))) (advance-buffer-offset 8)))))) (defun lookup-color (colormap name) (declare (type colormap colormap) (type stringable name)) (declare (clx-values screen-color true-color)) (let* ((display (colormap-display colormap)) (string (string name)) (length (length string))) (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16) ((colormap colormap) (card16 length) (pad16 nil) (string string)) (values (make-color :red (rgb-val-get 14) :green (rgb-val-get 16) :blue (rgb-val-get 18)) (make-color :red (rgb-val-get 8) :green (rgb-val-get 10) :blue (rgb-val-get 12)))))) (defun create-cursor (&key (source (required-arg source)) mask (x (required-arg x)) (y (required-arg y)) (foreground (required-arg foreground)) (background (required-arg background))) (declare (type pixmap source) ;; required (type (or null pixmap) mask) (type card16 x y) ;; required (type (or null color) foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (pixmap-display source)) (cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display +x-createcursor+) (resource-id cid) (pixmap source) ((or null pixmap) mask) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background)) (card16 x y)) cursor)) (defun create-glyph-cursor (&key (source-font (required-arg source-font)) (source-char (required-arg source-char)) mask-font mask-char (foreground (required-arg foreground)) (background (required-arg background))) (declare (type font source-font) ;; Required (type card16 source-char) ;; Required (type (or null font) mask-font) (type (or null card16) mask-char) (type color foreground background)) ;; required (declare (clx-values cursor)) (let* ((display (font-display source-font)) (cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor)) (source-font-id (font-id source-font)) (mask-font-id (if mask-font (font-id mask-font) 0))) (setf (cursor-id cursor) cid) (unless mask-char (setq mask-char 0)) (with-buffer-request (display +x-createglyphcursor+) (resource-id cid source-font-id mask-font-id) (card16 source-char) (card16 mask-char) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background))) cursor)) (defun free-cursor (cursor) (declare (type cursor cursor)) (let ((display (cursor-display cursor))) (with-buffer-request (display +x-freecursor+) (cursor cursor)) (deallocate-resource-id display (cursor-id cursor) 'cursor))) (defun recolor-cursor (cursor foreground background) (declare (type cursor cursor) (type color foreground background)) (with-buffer-request ((cursor-display cursor) +x-recolorcursor+) (cursor cursor) (rgb-val (color-red foreground) (color-green foreground) (color-blue foreground)) (rgb-val (color-red background) (color-green background) (color-blue background)) )) (defun query-best-cursor (width height drawable) (declare (type card16 width height) (type (or drawable display) drawable)) (declare (clx-values width height)) ;; Drawable can be a display for compatibility. (multiple-value-bind (display drawable) (if (type? drawable 'drawable) (values (drawable-display drawable) drawable) (values drawable (screen-root (display-default-screen drawable)))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 0) (window drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-best-tile (width height drawable) (declare (type card16 width height) (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 1) (drawable drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-best-stipple (width height drawable) (declare (type card16 width height) (type drawable drawable)) (declare (clx-values width height)) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16) ((data 2) (drawable drawable) (card16 width height)) (values (card16-get 8) (card16-get 10))))) (defun query-extension (display name) (declare (type display display) (type stringable name)) (declare (clx-values major-opcode first-event first-error)) (let ((string (string name))) (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8) ((card16 (length string)) (pad16 nil) (string string)) (and (boolean-get 8) ;; If present (values (card8-get 9) (card8-get 10) (card8-get 11)))))) (defun list-extensions (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence string))) (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8) () (values (read-sequence-string buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+)))) (defun change-keyboard-control (display &key key-click-percent bell-percent bell-pitch bell-duration led led-mode key auto-repeat-mode) (declare (type display display) (type (or null (member :default) int16) key-click-percent bell-percent bell-pitch bell-duration) (type (or null card8) led key) (type (or null (member :on :off)) led-mode) (type (or null (member :on :off :default)) auto-repeat-mode)) (when (eq key-click-percent :default) (setq key-click-percent -1)) (when (eq bell-percent :default) (setq bell-percent -1)) (when (eq bell-pitch :default) (setq bell-pitch -1)) (when (eq bell-duration :default) (setq bell-duration -1)) (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32)) (mask (integer key-click-percent bell-percent bell-pitch bell-duration) (card32 led) ((member :off :on) led-mode) (card32 key) ((member :off :on :default) auto-repeat-mode)))) (defun keyboard-control (display) (declare (type display display)) (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration led-mask global-auto-repeat auto-repeats)) (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32)) () (values (card8-get 12) (card8-get 13) (card16-get 14) (card16-get 16) (card32-get 8) (member8-get 1 :off :on) (bit-vector256-get 20)))) ;; The base volume should ;; be considered to be the "desired" volume in the normal case; that is, a ;; typical application should call XBell with 0 as the percent. Rather ;; than using a simple sum, the percent argument is instead used as the ;; percentage of the remaining range to alter the base volume by. That is, ;; the actual volume is: ;; if percent>=0: base - [(base * percent) / 100] + percent ;; if percent<0: base + [(base * percent) / 100] (defun bell (display &optional (percent-from-normal 0)) ;; It is assumed that an eventual audio extension to X will provide more complete control. (declare (type display display) (type int8 percent-from-normal)) (with-buffer-request (display +x-bell+) (data (int8->card8 percent-from-normal)))) (defun pointer-mapping (display &key (result-type 'list)) (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values sequence)) ;; Sequence of card (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8) () (values (sequence-get :length (card8-get 1) :result-type result-type :format card8 :index +replysize+)))) (defun set-pointer-mapping (display map) ;; Can signal device-busy. (declare (type display display) (type sequence map)) ;; Sequence of card8 (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8) ((data (length map)) ((sequence :format card8) map)) (values (boolean-get 1))) (x-error 'device-busy :display display)) map) (defsetf pointer-mapping set-pointer-mapping) (defun change-pointer-control (display &key acceleration threshold) ;; Acceleration is rationalized if necessary. (declare (type display display) (type (or null (member :default) number) acceleration) (type (or null (member :default) integer) threshold)) (flet ((rationalize16 (number) ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers (declare (type number number)) (declare (clx-values numerator denominator)) (do* ((rational (rationalize number)) (numerator (numerator rational) (ash numerator -1)) (denominator (denominator rational) (ash denominator -1))) ((or (= numerator 1) (and (< (abs numerator) #x8000) (< denominator #x8000))) (values numerator (min denominator #x7fff)))))) (declare (inline rationalize16)) (let ((acceleration-p 1) (threshold-p 1) (numerator 0) (denominator 1)) (declare (type card8 acceleration-p threshold-p) (type int16 numerator denominator)) (cond ((eq acceleration :default) (setq numerator -1)) (acceleration (multiple-value-setq (numerator denominator) (rationalize16 acceleration))) (t (setq acceleration-p 0))) (cond ((eq threshold :default) (setq threshold -1)) ((null threshold) (setq threshold -1 threshold-p 0))) (with-buffer-request (display +x-changepointercontrol+) (int16 numerator denominator threshold) (card8 acceleration-p threshold-p))))) (defun pointer-control (display) (declare (type display display)) (declare (clx-values acceleration threshold)) (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16) () (values (/ (card16-get 8) (card16-get 10)) ; Should we float this? (card16-get 12)))) (defun set-screen-saver (display timeout interval blanking exposures) ;; Timeout and interval are in seconds, will be rounded to minutes. (declare (type display display) (type (or (member :default) int16) timeout interval) (type (member :on :off :default :yes :no) blanking exposures)) (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off))) (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off))) (when (eq timeout :default) (setq timeout -1)) (when (eq interval :default) (setq interval -1)) (with-buffer-request (display +x-setscreensaver+) (int16 timeout interval) ((member8 :on :off :default) blanking exposures))) (defun screen-saver (display) ;; Returns timeout and interval in seconds. (declare (type display display)) (declare (clx-values timeout interval blanking exposures)) (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16)) () (values (card16-get 8) (card16-get 10) (member8-get 12 :on :off :default) (member8-get 13 :on :off :default)))) (defun activate-screen-saver (display) (declare (type display display)) (with-buffer-request (display +x-forcescreensaver+) (data 1))) (defun reset-screen-saver (display) (declare (type display display)) (with-buffer-request (display +x-forcescreensaver+) (data 0))) (defun add-access-host (display host &optional (family :internet)) ;; A string must be acceptable as a host, but otherwise the possible types for ;; host are not constrained, and will likely be very system dependent. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family nil)) (defun remove-access-host (display host &optional (family :internet)) ;; A string must be acceptable as a host, but otherwise the possible types for ;; host are not constrained, and will likely be very system dependent. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (change-access-host display host family t)) (defun change-access-host (display host family remove-p) (declare (type display display) (type (or stringable list) host) (type (or null (member :internet :decnet :chaos) card8) family)) (unless (consp host) (setq host (host-address host family))) (let ((family (car host)) (address (cdr host))) (with-buffer-request (display +x-changehosts+) ((data boolean) remove-p) (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family)) (card16 (length address)) ((sequence :format card8) address)))) (defun access-hosts (display &optional (result-type 'list)) ;; The type of host objects returned is not constrained, except that the hosts must ;; be acceptable to add-access-host and remove-access-host. ;; This implementation uses a list whose car is the family keyword ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes. (declare (type display display) (type t result-type)) ;; CL type (declare (clx-values (clx-sequence host) enabled-p)) (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16)) () (let* ((enabled-p (boolean-get 1)) (nhosts (card16-get 8)) (sequence (make-sequence result-type nhosts))) (advance-buffer-offset +replysize+) (dotimes (i nhosts) (let ((family (card8-get 0)) (len (card16-get 2))) (setf (elt sequence i) (cons (if (< family 3) (svref '#(:internet :decnet :chaos) family) family) (sequence-get :length len :format card8 :result-type 'list :index (+ buffer-boffset 4)))) (advance-buffer-offset (+ 4 (* 4 (ceiling len 4)))))) (values sequence enabled-p)))) (defun access-control (display) (declare (type display display)) (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8) () (boolean-get 1))) (defun set-access-control (display enabled-p) (declare (type display display) (type generalized-boolean enabled-p)) (with-buffer-request (display +x-changeaccesscontrol+) ((data boolean) enabled-p)) enabled-p) (defsetf access-control set-access-control) (defun close-down-mode (display) ;; setf'able ;; Cached locally in display object. (declare (type display display)) (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil))) (display-close-down-mode display)) (defun set-close-down-mode (display mode) ;; Cached locally in display object. (declare (type display display) (type (member :destroy :retain-permanent :retain-temporary) mode)) (setf (display-close-down-mode display) mode) (with-buffer-request (display +x-changeclosedownmode+ :sizes (32)) ((data (member :destroy :retain-permanent :retain-temporary)) mode)) mode) (defsetf close-down-mode set-close-down-mode) (defun kill-client (display resource-id) (declare (type display display) (type resource-id resource-id)) (with-buffer-request (display +x-killclient+) (resource-id resource-id))) (defun kill-temporary-clients (display) (declare (type display display)) (with-buffer-request (display +x-killclient+) (resource-id 0))) (defun no-operation (display) (declare (type display display)) (with-buffer-request (display +x-nooperation+))) cmucl-21a/src/clx/resource.lisp000066400000000000000000000633631260377556400166710ustar00rootroot00000000000000;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;; RESOURCE - Lisp version of XLIB's Xrm resource manager ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: resource.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;; The C version of this uses a 64 entry hash table at each entry. ;; Small hash tables lose in Lisp, so we do linear searches on lists. (defstruct (resource-database (:copier nil) (:predicate nil) (:print-function print-resource-database) (:constructor make-resource-database-internal) #+explorer (:callable-constructors nil) ) (name nil :type stringable :read-only t) (value nil) (tight nil :type list) ;; List of resource-database (loose nil :type list) ;; List of resource-database ) (defun print-resource-database (database stream depth) (declare (type resource-database database) (ignore depth)) (print-unreadable-object (database stream :type t) (write-string (string (resource-database-name database)) stream) (when (resource-database-value database) (write-string " " stream) (prin1 (resource-database-value database) stream)))) ;; The value slot of the top-level resource-database structure is used for a ;; time-stamp. (defun make-resource-database () ;; Make a resource-database with initial timestamp of 0 (make-resource-database-internal :name "Top-Level" :value 0)) (defun resource-database-timestamp (database) (declare (type resource-database database)) (resource-database-value database)) (defun incf-resource-database-timestamp (database) ;; Increment the timestamp (declare (type resource-database database)) (let ((timestamp (resource-database-value database))) (setf (resource-database-value database) (if (= timestamp most-positive-fixnum) most-negative-fixnum (1+ timestamp))))) ;; DEBUG FUNCTION (not exported) (defun print-db (entry &optional (level 0) type) ;; Debug function to print a resource database (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]" level (resource-database-name entry) (eq type 'loose) (resource-database-value entry)) (when (resource-database-tight entry) (dolist (tight (resource-database-tight entry)) (print-db tight (+ 2 level) 'tight))) (when (resource-database-loose entry) (dolist (loose (resource-database-loose entry)) (print-db loose (+ 2 level) 'loose)))) ;; DEBUG FUNCTION #+comment (defun print-search-table (table) (terpri) (dolist (dbase-list table) (format t "~%~s" dbase-list) (dolist (db dbase-list) (print-db db) (dolist (dblist table) (unless (eq dblist dbase-list) (when (member db dblist) (format t " duplicate at ~s" db)))) ))) ;; ;; If this is true, resource symbols will be compared in a case-insensitive ;; manner, and converting a resource string to a keyword will uppercaseify it. ;; (defparameter *uppercase-resource-symbols* nil) (defun resource-key (stringable) ;; Ensure STRINGABLE is a keyword. (declare (type stringable stringable)) (etypecase stringable (symbol (if (keywordp (the symbol stringable)) stringable (kintern (symbol-name (the symbol stringable))))) (string (if *uppercase-resource-symbols* (setq stringable (#-allegro string-upcase #+allegro correct-case (the string stringable)))) (kintern (the string stringable))))) (defun stringable-equal (a b) ;; Compare two stringables. ;; Ignore case when comparing to a symbol. (declare (type stringable a b)) (declare (clx-values generalized-boolean)) (etypecase a (string (etypecase b (string (string= (the string a) (the string b))) (symbol (if *uppercase-resource-symbols* (string-equal (the string a) (the string (symbol-name (the symbol b)))) (string= (the string a) (the string (symbol-name (the symbol b)))))))) (symbol (etypecase b (string (if *uppercase-resource-symbols* (string-equal (the string (symbol-name (the symbol a))) (the string b)) (string= (the string (symbol-name (the symbol a))) (the string b)))) (symbol (string= (the string (symbol-name (the symbol a))) (the string (symbol-name (the symbol b))))))))) ;;;----------------------------------------------------------------------------- ;;; Add/delete resource (defun add-resource (database name-list value) ;; name-list is a list of either strings or symbols. If a symbol, ;; case-insensitive comparisons will be used, if a string, ;; case-sensitive comparisons will be used. The symbol '* or ;; string "*" are used as wildcards, matching anything or nothing. (declare (type resource-database database) (type (clx-list stringable) name-list) (type t value)) (unless value (error "Null resource values are ignored")) (incf-resource-database-timestamp database) (do* ((list name-list (cdr list)) (name (car list) (car list)) (node database) (loose-p nil)) ((endp list) (setf (resource-database-value node) value)) ;; Key is the first name that isn't * (if (stringable-equal name "*") (setq loose-p t) ;; find the entry associated with name (progn (do ((entry (if loose-p (resource-database-loose node) (resource-database-tight node)) (cdr entry))) ((endp entry) ;; Entry not found - create a new one (setq entry (make-resource-database-internal :name name)) (if loose-p (push entry (resource-database-loose node)) (push entry (resource-database-tight node))) (setq node entry)) (when (stringable-equal name (resource-database-name (car entry))) ;; Found entry - use it (return (setq node (car entry))))) (setq loose-p nil))))) (defun delete-resource (database name-list) (declare (type resource-database database) (type list name-list)) (incf-resource-database-timestamp database) (delete-resource-internal database name-list)) (defun delete-resource-internal (database name-list) (declare (type resource-database database) (type (clx-list stringable) name-list)) (do* ((list name-list (cdr list)) (string (car list) (car list)) (node database) (loose-p nil)) ((endp list) nil) ;; Key is the first name that isn't * (if (stringable-equal string "*") (setq loose-p t) ;; find the entry associated with name (progn (do* ((first-entry (if loose-p (resource-database-loose node) (resource-database-tight node))) (entry-list first-entry (cdr entry-list)) (entry (car entry-list) (car entry-list))) ((endp entry-list) ;; Entry not found - exit (return-from delete-resource-internal nil)) (when (stringable-equal string (resource-database-name entry)) (when (cdr list) (delete-resource-internal entry (cdr list))) (when (and (null (resource-database-loose entry)) (null (resource-database-tight entry))) (if loose-p (setf (resource-database-loose node) (delete entry (resource-database-loose node) :test #'eq :count 1)) (setf (resource-database-tight node) (delete entry (resource-database-tight node) :test #'eq :count 1)))) (return-from delete-resource-internal t))) (setq loose-p nil))))) ;;;----------------------------------------------------------------------------- ;;; Get Resource (defun get-resource (database value-name value-class full-name full-class) ;; Return the value of the resource in DATABASE whose partial name ;; most closely matches (append full-name (list value-name)) and ;; (append full-class (list value-class)). (declare (type resource-database database) (type stringable value-name value-class) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let ((names (append full-name (list value-name))) (classes (append full-class (list value-class)))) (let* ((result (get-entry (resource-database-tight database) (resource-database-loose database) names classes))) (when result (resource-database-value result))))) (defun get-entry-lookup (table name names classes) (declare (type list table names classes) (symbol name)) (dolist (entry table) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (if (null (cdr names)) (return entry) (let ((result (get-entry (resource-database-tight entry) (resource-database-loose entry) (cdr names) (cdr classes)))) (declare (type (or null resource-database) result)) (when result (return result) )))))) (defun get-entry (tight loose names classes &aux result) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type symbol name class)) (cond ((and tight (get-entry-lookup tight name names classes))) ((and loose (get-entry-lookup loose name names classes))) ((and tight (not (stringable-equal name class)) (get-entry-lookup tight class names classes))) ((and loose (not (stringable-equal name class)) (get-entry-lookup loose class names classes))) (loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (when (setq result (get-entry-lookup loose name names classes)) (return result)) (when (and (not (stringable-equal name class)) (setq result (get-entry-lookup loose class names classes))) (return result)) ))))) ;;;----------------------------------------------------------------------------- ;;; Get-resource with search-table (defun get-search-resource (table name class) ;; (get-search-resource (get-search-table database full-name full-class) ;; value-name value-class) ;; is equivalent to ;; (get-resource database value-name value-class full-name full-class) ;; But since most of the work is done by get-search-table, ;; get-search-resource is MUCH faster when getting several resources with ;; the same full-name/full-class (declare (type list table) (type stringable name class)) (let ((do-class (and class (not (stringable-equal name class))))) (dolist (dbase-list table) (declare (type list dbase-list)) (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal name (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))) (when do-class (dolist (dbase dbase-list) (declare (type resource-database dbase)) (when (stringable-equal class (resource-database-name dbase)) (return-from get-search-resource (resource-database-value dbase)))))))) (defvar *get-table-result*) (defun get-search-table (database full-name full-class) ;; Return a search table for use with get-search-resource. (declare (type resource-database database) (type (clx-list stringable) full-name full-class)) (declare (clx-values value)) (let* ((tight (resource-database-tight database)) (loose (resource-database-loose database)) (result (cons nil nil)) (*get-table-result* result)) (declare (type list tight loose) (type cons result)) (when (or tight loose) (when full-name (get-tables tight loose full-name full-class)) ;; Pick up bindings of the form (* name). These are the elements of ;; top-level loose without further tight/loose databases. ;; ;; (Hack: these bindings belong in ANY search table, so recomputing them ;; is a drag. True fix involves redesigning entire lookup ;; data-structure/algorithm.) ;; (let ((universal-bindings (remove nil loose :test-not #'eq :key #'(lambda (database) (or (resource-database-tight database) (resource-database-loose database)))))) (when universal-bindings (setf (cdr *get-table-result*) (list universal-bindings))))) (cdr result))) (defun get-tables-lookup (dbase name names classes) (declare (type list dbase names classes) (type symbol name)) (declare (optimize speed)) (dolist (entry dbase) (declare (type resource-database entry)) (when (stringable-equal name (resource-database-name entry)) (let ((tight (resource-database-tight entry)) (loose (resource-database-loose entry))) (declare (type list tight loose)) (when (or tight loose) (if (cdr names) (get-tables tight loose (cdr names) (cdr classes)) (when tight (let ((result *get-table-result*)) ;; Put tight at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons tight nil)))))) (when loose (let ((result *get-table-result*)) ;; Put loose at end of *get-table-result* (setf (cdr result) (setq *get-table-result* (cons loose nil)))))))))) (defun get-tables (tight loose names classes) (declare (type list tight loose names classes)) (let ((name (car names)) (class (car classes))) (declare (type symbol name class)) (when tight (get-tables-lookup tight name names classes)) (when loose (get-tables-lookup loose name names classes)) (when (and tight (not (stringable-equal name class))) (get-tables-lookup tight class names classes)) (when (and loose (not (stringable-equal name class))) (get-tables-lookup loose class names classes)) (when loose (loop (pop names) (pop classes) (unless (and names classes) (return nil)) (setq name (car names) class (car classes)) (get-tables-lookup loose name names classes) (unless (stringable-equal name class) (get-tables-lookup loose class names classes)) )))) ;;;----------------------------------------------------------------------------- ;;; Utility functions (defun map-resource (database function &rest args) ;; Call FUNCTION on each resource in DATABASE. ;; FUNCTION is called with arguments (name-list value . args) (declare (type resource-database database) (type (function (list t &rest t) t) function) #+clx-ansi-common-lisp (dynamic-extent function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function) (dynamic-extent args)) (declare (clx-values nil)) (labels ((map-resource-internal (database function args name) (declare (type resource-database database) (type (function (list t &rest t) t) function) (type list name) #+clx-ansi-common-lisp (dynamic-extent function) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg function)) (let ((tight (resource-database-tight database)) (loose (resource-database-loose database))) (declare (type list tight loose)) (dolist (resource tight) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name)))) (dolist (resource loose) (declare (type resource-database resource)) (let ((value (resource-database-value resource)) (name (append name (list "*" (resource-database-name resource))))) (if value (apply function name value args) (map-resource-internal resource function args name))))))) (map-resource-internal database function args nil))) (defun merge-resources (database with-database) (declare (type resource-database database with-database)) (declare (clx-values resource-database)) (map-resource database #'(lambda (name value database) (add-resource database name value)) with-database) with-database) (defun char-memq (key char) ;; Used as a test function for POSITION (declare (type base-char char)) (member char key)) (defmacro resource-with-open-file ((stream pathname &rest options) &body body) ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the ;; stream (let ((abortp (gensym)) (streamp (gensym))) `(let* ((,abortp t) (,streamp (streamp pathname)) (,stream (if ,streamp pathname (open ,pathname ,@options)))) (unwind-protect (multiple-value-prog1 (progn ,@body) (setq ,abortp nil)) (unless ,streamp (close stream :abort ,abortp)))))) (defun read-resources (database pathname &key key test test-not) ;; Merges resources from a file in standard X11 format with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (resource-with-open-file (stream pathname) (loop (let ((string (read-line stream nil :eof))) (declare (type (or string keyword) string)) (when (eq string :eof) (return database)) (let* ((end (length string)) (i (position '(#\tab #\space) string :test-not #'char-memq :end end)) (term nil)) (declare (type array-index end) (type (or null array-index) i term)) (when i ;; else blank line (case (char string i) (#\! nil) ;; Comment - skip ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip (#\# ;; Include (setq term (position '(#\tab #\space) string :test #'char-memq :start i :end end)) (when (string-equal string "#INCLUDE" :start1 i :end1 term) (let ((path (merge-pathnames (string-trim '(#\tab #\space #\") (subseq string (1+ term))) (truename stream)))) (read-resources database path :key key :test test :test-not test-not)))) (otherwise (multiple-value-bind (name-list value) (parse-resource string i end) (when name-list (when key (setq value (funcall key value))) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (add-resource database name-list value)))))))))))) (defun parse-resource (string &optional (start 0) end) ;; Parse a resource specfication string into a list of names and a value ;; string (declare (type string string) (type array-index start) (type (or null array-index) end)) (declare (clx-values name-list value)) (do ((i start) (end (or end (length string))) (term) (name-list)) ((>= i end)) (declare (type array-index end) (type (or null array-index) i term)) (setq term (position '(#\. #\* #\:) string :test #'char-memq :start i :end end)) (case (and term (char string term)) ;; Name seperator (#\. (when (> term i) (push (subseq string i term) name-list))) ;; Wildcard seperator (#\* (when (> term i) (push (subseq string i term) name-list)) (push '* name-list)) ;; Value separator (#\: (push (subseq string i term) name-list) (return (values (nreverse name-list) (string-trim '(#\tab #\space) (subseq string (1+ term)))))) (otherwise (return (values (nreverse name-list) (subseq string i term))))) (setq i (1+ term)))) (defun write-resources (database pathname &key write test test-not) ;; Write resources to PATHNAME in the standard X11 format. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type (or pathname string stream) pathname) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (resource-with-open-file (stream pathname :direction :output) (map-resource database #'(lambda (name-list value stream write test test-not) (when (cond (test (funcall test name-list value)) (test-not (not (funcall test-not name-list value))) (t t)) (let ((previous (car name-list))) (princ previous stream) (dolist (name (cdr name-list)) (unless (or (stringable-equal name "*") (stringable-equal previous "*")) (write-char #\. stream)) (setq previous name) (princ name stream))) (write-string ": " stream) (funcall write value stream) (terpri stream))) stream (or write #'princ) test test-not)) database) (defun wm-resources (database window &key key test test-not) ;; Takes the resources associated with the RESOURCE_MANAGER property ;; of WINDOW (if any) and merges them with DATABASE. ;; KEY is a function used for converting value-strings, the default is ;; identity. TEST and TEST-NOT are predicates used for filtering ;; which resources to include in the database. They are called with ;; the name and results of the KEY function. (declare (type resource-database database) (type window window) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not)) (declare (clx-values resource-database)) (let ((string (get-property window :RESOURCE_MANAGER :type :STRING :result-type 'string :transform #'xlib::card8->char))) (when string (with-input-from-string (stream string) (read-resources database stream :key key :test test :test-not test-not))))) (defun set-wm-resources (database window &key write test test-not) ;; Sets the resources associated with the RESOURCE_MANAGER property ;; of WINDOW. ;; WRITE is a function used for writing values, the default is #'princ ;; TEST and TEST-NOT are predicates used for filtering which resources ;; to include in the database. They are called with the name and value. (declare (type resource-database database) (type window window) (type (or null (function (string stream) t)) write) (type (or null (function (list t) generalized-boolean)) test test-not)) (xlib::set-string-property window :RESOURCE_MANAGER (with-output-to-string (stream) (write-resources database stream :write write :test test :test-not test-not)))) (defun root-resources (screen &key database key test test-not) "Returns a resource database containing the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. If an existing DATABASE is given, then resource values are merged with the DATABASE and the modified DATABASE is returned. TEST and TEST-NOT are predicates for selecting which resources are read. Arguments are a resource name list and a resource value. The KEY function, if given, is called to convert a resource value string to the value given to TEST or TEST-NOT." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (string) t)) key) (type (or null (function (list t) generalized-boolean)) test test-not) (clx-values resource-database)) (let* ((screen (if (type? screen 'display) (display-default-screen screen) screen)) (window (screen-root screen)) (database (or database (make-resource-database)))) (wm-resources database window :key key :test test :test-not test-not) database)) (defun set-root-resources (screen &key test test-not (write #'princ) database) "Changes the contents of the root window RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display, then its default screen is used. TEST and TEST-NOT are predicates for selecting which resources from the DATABASE are written. Arguments are a resource name list and a resource value. The WRITE function is used to convert a resource value into a string stored in the property." (declare (type (or screen display) screen) (type (or null resource-database) database) (type (or null (function (list t) generalized-boolean)) test test-not) (type (or null (function (string stream) t)) write) (clx-values resource-database)) (let* ((screen (if (type? screen 'display) (display-default-screen screen) screen)) (window (screen-root screen))) (set-wm-resources database window :write write :test test :test-not test-not) database)) (defsetf root-resources (screen &key test test-not (write #'princ))(database) `(set-root-resources ,screen :test ,test :test-not ,test-not :write ,write :database ,database)) (defun initialize-resource-database (display) ;; This function is (supposed to be) equivalent to the Xlib initialization ;; code. (declare (type display display)) (let ((rdb (make-resource-database)) (rootwin (screen-root (car (display-roots display))))) ;; First read the server defaults if present, otherwise from the default ;; resource file (if (get-property rootwin :RESOURCE_MANAGER) (xlib:wm-resources rdb rootwin) (let ((path (default-resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path)))) ;; Next read from the resources file (let ((path (resources-pathname))) (when (and path (probe-file path)) (read-resources rdb path))) (setf (display-xdefaults display) rdb))) cmucl-21a/src/clx/screensaver.lisp000066400000000000000000000053201260377556400173470ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 MIT Screensaver extension ;;; Created: 2005-08-28 01:41 ;;; Author: Istvan Marko ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Istvan Marko ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; Description: ;;; ;;; This is a partial interface to the MIT-SCREEN-SAVER ;;; extension. Only the ScreenSaverQueryVersion and ;;; ScreenSaverQueryInfo requests are implemented because I couldn't ;;; think of a use for the rest. In fact, the only use I see for this ;;; extension is screen-saver-get-idle which provides and easy way to ;;; find out how long has it been since the last keyboard or mouse ;;; activity. ;;; A description of this extension can be found at ;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution. (in-package :xlib) (export '(screen-saver-query-version screen-saver-query-info screen-saver-get-idle) :xlib) (define-extension "MIT-SCREEN-SAVER") (defun screen-saver-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 0) (card8 1) ;client major version (card8 0) ;client minor version (card16 0)) ; unused (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun screen-saver-query-info (display drawable) (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER") nil) ((data 1) (drawable drawable)) (values (card8-get 1) ; state: off, on, disabled (window-get 8) ; screen saver window if active (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active (card32-get 16) ; idle msecs (card8-get 24)))) ; kind: Blanked, Internal, External (defun screen-saver-get-idle (display drawable) "How long has it been since the last keyboard or mouse input" (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable) (declare (ignore state window kind)) (values idle tilorsince))) cmucl-21a/src/clx/shape.lisp000066400000000000000000000157671260377556400161470ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 Shape extension ;;; Created: 1999-05-14 11:31 ;;; Author: Gilbert Baumann ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999 by Gilbert Baumann ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz #+cmu (ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (export '(shape-query-version shape-rectangles shape-mask shape-combine shape-offset shape-query-extents shape-select-input shape-input-selected-p shape-get-rectangles) :xlib) (define-extension "SHAPE" :events (:shape-notify)) (declare-event :shape-notify ((data (member8 :bounding :clip)) kind) ;shape kind (card16 sequence) (window (window event-window)) ;affected window (int16 x) ;extents (int16 y) (card16 width) (card16 height) ((or null card32) time) ;timestamp (boolean shaped-p)) (defun encode-shape-kind (kind) (ecase kind (:bounding 0) (:clip 1))) (defun encode-shape-operation (operation) (ecase operation (:set 0) (:union 1) (:interset 2) (:subtract 3) (:invert 4))) (defun encode-shape-rectangle-ordering (ordering) (ecase ordering ((:unsorted :un-sorted nil) 0) ((:y-sorted) 1) ((:yx-sorted) 2) ((:yx-banded) 3))) (defun shape-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes 16) ((data 0)) (values (card16-get 8) (card16-get 10)))) (defun shape-rectangles (window rectangles &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set) (ordering :unsorted)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 1) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-rectangle-ordering ordering)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((sequence :format int16) rectangles)))) (defun shape-mask (window pixmap &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 2) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card16 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((or pixmap (member :none)) pixmap)))) (defun shape-combine (window source-window &key (kind :bounding) (source-kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 3) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-kind source-kind)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) (window source-window)))) (defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 4) (card8 (encode-shape-kind kind)) (card8 0) (card8 0) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset)))) (defun shape-query-extents (window) (let* ((display (xlib:window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 5) (window window)) (values (boolean-get 8) ;bounding shaped (boolean-get 9) ;clip shaped (int16-get 12) ;bounding shape extents x (int16-get 14) ;bounding shape extents y (card16-get 16) ;bounding shape extents width (card16-get 18) ;bounding shape extents height (int16-get 20) ;clip shape extents x (int16-get 22) ;clip shape extents y (card16-get 24) ;clip shape extents width (card16-get 26))))) ;clip shape extents height (defun shape-select-input (window selected-p) (let* ((display (window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 6) (window window) (boolean selected-p)) )) (defun shape-input-selected-p (window) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8)) ((data 7) ;also wrong in documentation (window window)) (boolean-get 1)))) (defun shape-get-rectangles (window &optional (kind :bounding) (result-type 'list)) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 8) ;this was wrong in the specification (window window) (card8 (ecase kind (:bounding 0) (:clip 1)))) (values (sequence-get :length (print (* 4 (card32-get 8))) :result-type result-type :format int16 :index +replysize+) (ecase (card8-get 1) (0 :unsorted) (1 :y-sorted) (2 :yx-sorted) (3 :yx-banded) ))))) cmucl-21a/src/clx/sockcl.lisp000066400000000000000000000107501260377556400163100ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;;; Server Connection for kcl and ibcl ;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify, and distribute this software, provided that this complete ;;; copyright and permission notice is maintained, intact, in all copies and ;;; supporting documentation. ;;; ;;; Massachussetts Institute of Technology provides this software "as is" ;;; without express or implied warranty. ;;; ;;; Adapted from code by Roman Budzianowski - Project Athena/MIT ;;; make-two-way-stream is probably not a reasonable thing to do. ;;; A close on a two way stream probably does not close the substreams. ;;; I presume an :io will not work (maybe because it uses 1 buffer?). ;;; There should be some fast io (writes and reads...). ;;; Compile this file with compile-file. ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") #+cmu (ext:file-comment "$Id: sockcl.lisp,v 1.4 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;;; The cmpinclude.h file does not have this type definition from ;;; /h/object.h. We include it here so the ;;; compile-file will work without figuring out where the distribution ;;; directory is located. ;;; (CLINES " enum smmode { /* stream mode */ smm_input, /* input */ smm_output, /* output */ smm_io, /* input-output */ smm_probe, /* probe */ smm_synonym, /* synonym */ smm_broadcast, /* broadcast */ smm_concatenated, /* concatenated */ smm_two_way, /* two way */ smm_echo, /* echo */ smm_string_input, /* string input */ smm_string_output, /* string output */ smm_user_defined /* for user defined */ }; ") #-akcl (CLINES " struct stream { short t, m; FILE *sm_fp; /* file pointer */ object sm_object0; /* some object */ object sm_object1; /* some object */ int sm_int0; /* some int */ int sm_int1; /* some int */ short sm_mode; /* stream mode */ /* of enum smmode */ }; ") ;;;; Connect to the server. ;;; A lisp string is not a reasonable type for C, so copy the characters ;;; out and then call connect_to_server routine defined in socket.o (CLINES " int konnect_to_server(host,display) object host; /* host name */ int display; /* display number */ { int fd; /* file descriptor */ int i; char hname[BUFSIZ]; FILE *fout, *fin; if (host->st.st_fillp > BUFSIZ - 1) too_long_file_name(host); for (i = 0; i < host->st.st_fillp; i++) hname[i] = host->st.st_self[i]; hname[i] = '\\0'; /* doubled backslash for lisp */ fd = connect_to_server(hname,display); return(fd); } ") (defentry konnect-to-server (object int) (int "konnect_to_server")) ;;;; Make a one-way stream from a file descriptor. (CLINES " object konnect_stream(host,fd,flag,elem) object host; /* not really used */ int fd; /* file descriptor */ int flag; /* 0 input, 1 output */ object elem; /* 'string-char */ { struct stream *stream; char *mode; /* file open mode */ FILE *fp; /* file pointer */ enum smmode smm; /* lisp mode (a short) */ vs_mark; switch(flag){ case 0: smm = smm_input; mode = \"r\"; break; case 1: smm = smm_output; mode = \"w\"; break; default: FEerror(\"konnect_stream : wrong mode\"); } fp = fdopen(fd,mode); if (fp == NULL) { stream = Cnil; vs_push(stream); } else { stream = alloc_object(t_stream); stream->sm_mode = (short)smm; stream->sm_fp = fp; stream->sm_object0 = elem; stream->sm_object1 = host; stream->sm_int0 = stream->sm.sm_int1 = 0; vs_push(stream); setbuf(fp, alloc_contblock(BUFSIZ)); } vs_reset; return(stream); } ") (defentry konnect-stream (object int int object) (object "konnect_stream")) ;;;; Open an X stream (defun open-socket-stream (host display) (when (not (and (typep host 'string) ; sanity check the arguments (typep display 'fixnum))) (error "Host ~s or display ~s are bad." host display)) (let ((fd (konnect-to-server host display))) ; get a file discriptor (if (< fd 0) NIL (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input (stream-out (konnect-stream host fd 1 'string-char))) ; output (if (or (null stream-in) (null stream-out)) (error "Could not make i/o streams for fd ~d." fd)) (make-two-way-stream stream-in stream-out)) ))) cmucl-21a/src/clx/socket.c000066400000000000000000000105131260377556400155720ustar00rootroot00000000000000/* Copyright Massachusetts Institute of Technology 1988 */ /* * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived * systems. VMS and System V should plan to have their own version. * * This code was cribbed from lib/X/XConnDis.c. * Compile using * % cc -c socket.c -DUNIXCONN * * $Id: socket.c,v 1.5 2009/06/17 18:22:46 rtoy Rel $ */ #include #include #include #include #include #include #include #include #ifndef hpux #include #endif extern int errno; /* Certain (broken) OS's don't have this */ /* decl in errno.h */ #ifdef UNIXCONN #include #ifndef X_UNIX_PATH #ifdef hpux #define X_UNIX_PATH "/usr/spool/sockets/X11/" #define OLD_UNIX_PATH "/tmp/.X11-unix/X" #else /* hpux */ #define X_UNIX_PATH "/tmp/.X11-unix/X" #endif /* hpux */ #endif /* X_UNIX_PATH */ #endif /* UNIXCONN */ #ifndef hpux void bcopy(); #endif /* hpux */ /* * Attempts to connect to server, given host and display. Returns file * descriptor (network socket) or 0 if connection fails. */ int connect_to_server (host, display) char *host; int display; { struct sockaddr_in inaddr; /* INET socket address. */ struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; int addrlen; /* length of address */ #ifdef UNIXCONN struct sockaddr_un unaddr; /* UNIX socket address. */ #endif extern char *getenv(); extern struct hostent *gethostbyname(); int fd; /* Network socket */ { #ifdef UNIXCONN if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { /* Connect locally using Unix domain. */ unaddr.sun_family = AF_UNIX; (void) strcpy(unaddr.sun_path, X_UNIX_PATH); (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); addr = (struct sockaddr *) &unaddr; addrlen = strlen(unaddr.sun_path) + 2; /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { #ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ if (errno == ENOENT) { /* No such file or directory */ (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); addrlen = strlen(unaddr.sun_path) + 2; if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) return(-1); /* errno set by most recent system call. */ } else #endif /* hpux */ return(-1); /* errno set by system call. */ } } else #endif /* UNIXCONN */ { /* Get the statistics on the specified host. */ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { if ((host_ptr = gethostbyname(host)) == NULL) { /* No such host! */ errno = EINVAL; return(-1); } /* Check the address type for an internet host. */ if (host_ptr->h_addrtype != AF_INET) { /* Not an Internet host! */ errno = EPROTOTYPE; return(-1); } /* Set up the socket data. */ inaddr.sin_family = host_ptr->h_addrtype; #ifdef hpux (void) memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, sizeof(inaddr.sin_addr)); #else /* hpux */ (void) bcopy((char *)host_ptr->h_addr, (char *)&inaddr.sin_addr, sizeof(inaddr.sin_addr)); #endif /* hpux */ } else { inaddr.sin_family = AF_INET; } addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); inaddr.sin_port = display + X_TCP_PORT; inaddr.sin_port = htons(inaddr.sin_port); /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ return(-1); /* errno set by system call. */} /* make sure to turn off TCP coalescence */ #ifdef TCP_NODELAY { int mi = 1; setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); } #endif } /* * Changed 9/89 to retry connection if system call was interrupted. This * is necessary for multiprocessing implementations that use timers, * since the timer results in a SIGALRM. -- jdi */ while (connect(fd, addr, addrlen) == -1) { if (errno != EINTR) { (void) close (fd); return(-1); /* errno set by system call. */ } } } /* * Return the id if the connection succeeded. */ return(fd); } cmucl-21a/src/clx/test/000077500000000000000000000000001260377556400151155ustar00rootroot00000000000000cmucl-21a/src/clx/test/README000066400000000000000000000006161260377556400160000ustar00rootroot00000000000000$Id: README,v 1.1 2007/08/21 15:49:30 fgilham Rel $ Neither of these tests works correctly. image.lisp: Draws images on your screen. Doesn't do what it says it will do, but that's probably because of various assumptions it makes that aren't true. trapezoid.lisp: Doesn't compile and wouldn't work if it did because of lack of the extension that implements the "poly-fill-trapezoids" functions. cmucl-21a/src/clx/test/image.lisp000066400000000000000000000124671260377556400171020ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; Tests image code by randomly reading, copying and then writing images to ;;; the exact same place on the screen. If everything works, just the borders ;;; of the image windows appear. If one of these image windows is garbled, ;;; then somewhere something is broken. Entry point is the function ;;; IMAGE-TEST (in-package :xlib) (export '(image-test)) (defvar *image-test-host* "") (defvar *image-test-nimages* 25) (defvar *image-test-copy* t) (defvar *image-test-copy-random-subimage* t) (defvar *image-test-put-random-subimage* t) (defvar *image-test-get-image-result-type-choices* '(image-x image-x image-xy image-z)) (defvar *image-test-get-image-image-x-format-choices* '(:xy-pixmap :z-pixmap)) (defun image-test (&key (host *image-test-host*) (nimages *image-test-nimages*) (copy *image-test-copy*) (copy-random-subimage *image-test-copy-random-subimage*) (put-random-subimage *image-test-put-random-subimage*) (get-image-result-type-choices *image-test-get-image-result-type-choices*) (get-image-image-x-format-choices *image-test-get-image-image-x-format-choices*)) (declare (ignore host)) (let* ((display nil) (abort t) (images nil)) (loop (setq images nil) (unwind-protect (progn (setq display (open-default-display)) (let* ((screen (display-default-screen display)) (window (screen-root screen)) (gcontext (create-gcontext :foreground (screen-white-pixel screen) :background (screen-black-pixel screen) :drawable window :font (open-font display "fixed")))) (dotimes (i nimages) (let ((image (image-test-get-image window get-image-result-type-choices get-image-image-x-format-choices))) (format t "~&Image=~S~%" image) (let ((copy (if copy (image-test-copy-image image copy-random-subimage) image))) (format t "~&Copy=~S~%" copy) (push (list image copy) images) (image-test-put-image screen gcontext copy (concatenate 'string (image-info image) (image-info copy)) put-random-subimage)))) (unless (y-or-n-p "More ") (return)) (setq abort nil))) (close-display (shiftf display nil) :abort abort)) (sleep 10)) (reverse images))) (defun image-test-choose (list) (nth (random (length list)) list)) (defun image-test-get-image (window result-type-choices image-x-format-choices) (let* ((x (random (floor (drawable-width window) 3))) (y (random (floor (drawable-height window) 3))) (hw (floor (- (drawable-width window) x) 3)) (hh (floor (- (drawable-height window) y) 3)) (width (+ hw hw (random hw))) (height (+ hh hh (random hh))) (result-type (image-test-choose result-type-choices)) (format (ecase result-type (image-x (image-test-choose image-x-format-choices)) (image-xy :xy-pixmap) (image-z :z-pixmap))) (image (get-image window :x x :y y :width width :height height :format format :result-type result-type))) (setf (getf (image-plist image) :root-x) x) (setf (getf (image-plist image) :root-y) y) image)) (defun image-test-subimage-parameters (image random-subimage-p) (if random-subimage-p (let* ((x (random (floor (image-width image) 3))) (y (random (floor (image-height image) 3))) (hw (floor (- (image-width image) x) 3)) (hh (floor (- (image-height image) y) 3)) (width (+ hw hw (random hw))) (height (+ hh hh (random hh)))) (values x y width height)) (values 0 0 (image-width image) (image-height image)))) (defun image-test-copy-image (image random-subimage-p) (let ((result-type (if (zerop (random 2)) (type-of image) (etypecase image (image-x (ecase (image-x-format image) (:xy-pixmap 'image-xy) (:z-pixmap 'image-z))) ((or image-xy image-z) 'image-x))))) (multiple-value-bind (x y width height) (image-test-subimage-parameters image random-subimage-p) (incf (getf (image-plist image) :root-x) x) (incf (getf (image-plist image) :root-y) y) (copy-image image :x x :y y :width width :height height :result-type result-type)))) (defun image-test-put-image (screen gcontext image info random-subimage-p) (multiple-value-bind (src-x src-y width height) (image-test-subimage-parameters image random-subimage-p) (let* ((border-width 1) (root-x (getf (image-plist image) :root-x)) (root-y (getf (image-plist image) :root-y)) (x (+ src-x root-x (- border-width))) (y (+ src-y root-y (- border-width)))) (unless (or (zerop width) (zerop height)) (let ((window (create-window :parent (screen-root screen) :x x :y y :width width :height height :border-width border-width :background (screen-white-pixel screen) :override-redirect :on))) (map-window window) (display-finish-output (drawable-display window)) (put-image window gcontext image :x 0 :y 0 :src-x src-x :src-y src-y :width width :height height) (draw-image-glyphs window gcontext 0 (1- height) info) (display-finish-output (drawable-display window)) window))))) (defun image-info (image) (etypecase image (image-x (ecase (image-x-format image) (:xy-pixmap "XXY") (:z-pixmap "XZ "))) (image-xy "XY ") (image-z "Z "))) cmucl-21a/src/clx/test/trapezoid.lisp000066400000000000000000000045161260377556400200150ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- ;;; CLX trapezoid Extension test program ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (in-package :xlib) (defun zoid-test () ;; Display the part picture in /extensions/test/datafile (let* ((display (open-default-display)) (width 400) (height 400) (screen (display-default-screen display)) (black (screen-black-pixel screen)) (white (screen-white-pixel screen)) (win (create-window :parent (screen-root screen) :background black :border white :border-width 1 :colormap (screen-default-colormap screen) :bit-gravity :center :event-mask '(:exposure :key-press) :x 20 :y 20 :width width :height height)) (gc (create-gcontext :drawable win :background black :foreground white))) (initialize-extensions display) (map-window win) ; Map the window ;; Handle events (unwind-protect (loop (event-case (display :force-output-p t) (exposure ;; Come here on exposure events (window count) (when (zerop count) ;; Ignore all but the last exposure event (clear-area window) ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES (draw-filled-trapezoids window gc '(10 20 30 40 100 200)) (setf (gcontext-trapezoid-alignment gc) :y) (draw-filled-trapezoids window gc #(10 20 30 40 100 200)) (with-gcontext (gc :trapezoid-alignment :x) (draw-filled-trapezoids window gc '(40 50 60 70 140 240))) (setf (gcontext-trapezoid-alignment gc) :x) (draw-filled-trapezoids window gc #(40 50 60 70 80 90)) (with-gcontext (gc :trapezoid-alignment :y) (draw-filled-trapezoids window gc #(40 50 60 70 140 240))) (draw-glyphs window gc 10 10 "Press any key to exit") ;; Returning non-nil causes event-case to exit t)) (key-press () (return-from zoid-test t)))) (close-display display)))) cmucl-21a/src/clx/text.lisp000066400000000000000000001266201260377556400160220ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; CLX text keyboard and pointer requests ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: text.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) ;; Strings are broken up into chunks of this size (defparameter *max-string-size* 254) ;; In the functions below, the transform is used to convert an element of the ;; sequence into a font index. The transform is applied to each element of the ;; (sub)sequence, until either the transform returns nil or the end of the ;; (sub)sequence is reached. If transform returns nil for an element, the ;; index of that element in the sequence is returned, otherwise nil is ;; returned. (deftype translation-function () #+explorer t #-explorer '(function (sequence array-index array-index (or null font) vector array-index) (values array-index (or null int16 font) (or null int32)))) ;; In the functions below, if width is specified, it is assumed to be the pixel ;; width of whatever string of glyphs is actually drawn. Specifying width will ;; allow for appending the output of subsequent calls to the same protocol ;; request, provided gcontext has not been modified in the interim. If width ;; is not specified, appending of subsequent output might not occur. ;; Specifying width is simply a hint, for performance. Note that specifying ;; width may be difficult if transform can return nil. (defun translate-default (src src-start src-end font dst dst-start) ;; dst is guaranteed to have room for (- src-end src-start) integer elements, ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends ;; on context. font is the current font, if known. The function should ;; translate as many elements of src as possible into indexes in the current ;; font, and store them into dst. ;; ;; The first return value should be the src index of the first untranslated ;; element. If no further elements need to be translated, the second return ;; value should be nil. If a horizontal motion is required before further ;; translation, the second return value should be the delta in x coordinate. ;; If a font change is required for further translation, the second return ;; value should be the new font. If known, the pixel width of the translated ;; text can be returned as the third value; this can allow for appending of ;; subsequent output to the same protocol request, if no overall width has ;; been specified at the higher level. ;; (returns values: ending-index ;; (OR null horizontal-motion font) ;; (OR null translated-width)) (declare (type sequence src) (type array-index src-start src-end dst-start) (type (or null font) font) (type vector dst) (inline graphic-char-p)) (declare (clx-values integer (or null integer font) (or null integer))) (let ((min-char-index (and font (xlib:font-min-char font))) (max-char-index (and font (xlib:font-max-char font)))) (if (stringp src) (do ((i src-start (index+ i 1)) (j dst-start (index+ j 1)) (char)) ((index>= i src-end) i) (declare (type array-index i j)) (setf char (char->card8 (char src i))) (if (and font (or (< char min-char-index) (> char max-char-index))) (return i) (setf (aref dst j) char))) (do ((i src-start (index+ i 1)) (j dst-start (index+ j 1)) (elt)) ((index>= i src-end) i) (declare (type array-index i j)) (setq elt (elt src i)) (when (characterp elt) (setq elt (char->card8 elt))) (if (or (not (integerp elt)) (and font (< elt min-char-index) (> elt max-char-index))) (return i) (setf (aref dst j) elt)))))) ;; There is a question below of whether translate should always be required, or ;; if not, what the default should be or where it should come from. For ;; example, the default could be something that expected a string as src and ;; translated the CL standard character set to ASCII indexes, and ignored fonts ;; and bits. Or the default could expect a string but otherwise be "system ;; dependent". Or the default could be something that expected a vector of ;; integers and did no translation. Or the default could come from the ;; gcontext (but what about text-extents and text-width?). (defun text-extents (font sequence &key (start 0) end translate) ;; If multiple fonts are involved, font-ascent and font-descent will be the ;; maximums. If multiple directions are involved, the direction will be nil. ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values width ascent descent left right font-ascent font-descent direction (or null array-index))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((left-bearing 0) (right-bearing 0) ;; Sum of widths (width 0) (ascent 0) (descent 0) (overall-ascent (font-ascent font)) (overall-descent (font-descent font)) (overall-direction (font-direction font)) (next-start nil) (display (font-display font))) (declare (type int16 ascent descent overall-ascent overall-descent) (type int32 left-bearing right-bearing width) (type (or null array-index) next-start) (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) (end (index-min src-end (index+ src-start +buffer-text16-size+)) (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (font-ascent 0) (font-descent 0) (font-direction) (stop-p nil)) ((or stop-p (index>= src-start src-end)) (when (index< src-start src-end) (setq next-start src-start))) (declare (type buffer-text16 wbuf) (type array-index src-start src-end end buf-end) (type int16 font-ascent font-descent) (type generalized-boolean stop-p)) ;; Translate the text (multiple-value-setq (buf-end new-font) (funcall (or translate #'translate-default) sequence src-start end font wbuf 0)) (setq buf-end (- buf-end src-start)) (cond ((null new-font) (setq stop-p t)) ((integerp new-font) (incf width (the int32 new-font)))) (let (w a d l r) (if (or (font-char-infos-internal font) (font-local-only-p font)) ;; Calculate text extents locally (progn (multiple-value-setq (w a d l r) (text-extents-local font wbuf 0 buf-end nil)) (setq font-ascent (the int16 (font-ascent font)) font-descent (the int16 (font-descent font)) font-direction (font-direction font))) ;; Let the server calculate text extents (multiple-value-setq (w a d l r font-ascent font-descent font-direction) (text-extents-server font wbuf 0 buf-end))) (incf width (the int32 w)) (cond ((index= src-start start) (setq left-bearing (the int32 l)) (setq right-bearing (the int32 r)) (setq ascent (the int16 a)) (setq descent (the int16 d))) (t (setq left-bearing (the int32 (min left-bearing (the int32 l)))) (setq right-bearing (the int32 (max right-bearing (the int32 r)))) (setq ascent (the int16 (max ascent (the int16 a)))) (setq descent (the int16 (max descent (the int16 d))))))) (when (type? new-font 'font) (setq font new-font)) (setq overall-ascent (the int16 (max overall-ascent font-ascent))) (setq overall-descent (the int16 (max overall-descent font-descent))) (case overall-direction (:unknown (setq overall-direction font-direction)) (:left-to-right (unless (eq font-direction :left-to-right) (setq overall-direction nil))) (:right-to-left (unless (eq font-direction :right-to-left) (setq overall-direction nil)))))) (values width ascent descent left-bearing right-bearing overall-ascent overall-descent overall-direction next-start))) (defun text-width (font sequence &key (start 0) end translate) ;; Translate will always be called with a 16-bit dst buffer. (declare (type sequence sequence) (type (or font gcontext) font) (type array-index start) (type (or null array-index) end)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values integer (or null integer))) (when (type? font 'gcontext) (force-gcontext-changes font) (setq font (gcontext-font font t))) (check-type font font) (let* ((width 0) (next-start nil) (display (font-display font))) (declare (type int32 width) (type (or null array-index) next-start) (type display display)) (with-display (display) (do* ((wbuf (display-tbuf16 display)) (src-end (or end (length sequence))) (src-start start (index+ src-start buf-end)) (end (index-min src-end (index+ src-start +buffer-text16-size+)) (index-min src-end (index+ src-start +buffer-text16-size+))) (buf-end 0) (new-font) (stop-p nil)) ((or stop-p (index>= src-start src-end)) (when (index< src-start src-end) (setq next-start src-start))) (declare (type buffer-text16 wbuf) (type array-index src-start src-end end buf-end) (type generalized-boolean stop-p)) ;; Translate the text (multiple-value-setq (buf-end new-font) (funcall (or translate #'translate-default) sequence src-start end font wbuf 0)) (setq buf-end (- buf-end src-start)) (cond ((null new-font) (setq stop-p t)) ((integerp new-font) (incf width (the int32 new-font)))) (incf width (if (or (font-char-infos-internal font) (font-local-only-p font)) (text-extents-local font wbuf 0 buf-end :width-only) (text-width-server font wbuf 0 buf-end))) (when (type? new-font 'font) (setq font new-font)))) (values width next-start))) (defun text-extents-server (font sequence start end) (declare (type font font) (type sequence sequence) (type array-index start end)) (declare (clx-values width ascent descent left right font-ascent font-descent direction)) (let ((display (font-display font)) (length (index- end start)) (font-id (font-id font))) (declare (type display display) (type array-index length) (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32)) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) sequence)) (values (integer-get 16) (int16-get 12) (int16-get 14) (integer-get 20) (integer-get 24) (int16-get 8) (int16-get 10) (member8-get 1 :left-to-right :right-to-left))))) (defun text-width-server (font sequence start end) (declare (type (or font gcontext) font) (type sequence sequence) (type array-index start end)) (declare (clx-values integer)) (let ((display (font-display font)) (length (index- end start)) (font-id (font-id font))) (declare (type display display) (type array-index length) (type resource-id font-id)) (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32) (((data boolean) (oddp length)) (length (index+ (index-ceiling length 2) 2)) (resource-id font-id) ((sequence :format char2b :start start :end end :appending t) sequence)) (values (integer-get 16))))) (defun text-extents-local (font sequence start end width-only-p) (declare (type font font) (type sequence sequence) (type integer start end) (type generalized-boolean width-only-p)) (declare (clx-values width ascent descent overall-left overall-right)) (let* ((char-infos (font-char-infos font)) (font-info (font-font-info font))) (declare (type font-info font-info)) (declare (type (simple-array int16 (*)) char-infos)) (if (zerop (length char-infos)) ;; Fixed width font (let* ((font-width (max-char-width font)) (font-ascent (max-char-ascent font)) (font-descent (max-char-descent font)) (width (* (index- end start) font-width))) (declare (type int16 font-width font-ascent font-descent) (type int32 width)) (if width-only-p width (values width font-ascent font-descent (max-char-left-bearing font) (+ width (- font-width) (max-char-right-bearing font))))) ;; Variable-width font (let* ((first-col (font-info-min-byte2 font-info)) (num-cols (1+ (- (font-info-max-byte2 font-info) first-col))) (first-row (font-info-min-byte1 font-info)) (last-row (font-info-max-byte1 font-info)) (num-rows (1+ (- last-row first-row)))) (declare (type card8 first-col first-row last-row) (type card16 num-cols num-rows)) (if (or (plusp first-row) (plusp last-row)) ;; Matrix (16 bit) font (macrolet ((char-info-elt (sequence elt) `(let* ((char (the card16 (elt ,sequence ,elt))) (row (- (ash char -8) first-row)) (col (- (logand char #xff) first-col))) (declare (type card16 char) (type int16 row col)) (if (and (< -1 row num-rows) (< -1 col num-cols)) (index* 6 (index+ (index* row num-cols) col)) -1)))) (if width-only-p (do ((i start (index1+ i)) (width 0)) ((index>= i end) width) (declare (type array-index i) (type int32 width)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (incf width (the int16 (aref char-infos (index+ 2 n))))))) ;; extents (do ((i start (index1+ i)) (width 0) (ascent #x-7fff) (descent #x-7fff) (left #x7fff) (right #x-7fff)) ((index>= i end) (values width ascent descent left right)) (declare (type array-index i) (type int16 ascent descent) (type int32 width left right)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (setq left (min left (+ width (aref char-infos n)))) (setq right (max right (+ width (aref char-infos (index1+ n))))) (incf width (aref char-infos (index+ 2 n))) (setq ascent (max ascent (aref char-infos (index+ 3 n)))) (setq descent (max descent (aref char-infos (index+ 4 n))))))))) ;; Non-matrix (8 bit) font ;; The code here is identical to the above, except for the following macro: (macrolet ((char-info-elt (sequence elt) `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col))) (declare (type int16 col)) (if (< -1 col num-cols) (index* 6 col) -1)))) (if width-only-p (do ((i start (index1+ i)) (width 0)) ((index>= i end) width) (declare (type array-index i) (type int32 width)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (incf width (the int16 (aref char-infos (index+ 2 n))))))) ;; extents (do ((i start (index1+ i)) (width 0) (ascent #x-7fff) (descent #x-7fff) (left #x7fff) (right #x-7fff)) ((index>= i end) (values width ascent descent left right)) (declare (type array-index i) (type int16 ascent descent) (type int32 width left right)) (let ((n (char-info-elt sequence i))) (declare (type fixnum n)) (unless (minusp n) ;; Ignore characters not in the font (setq left (min left (+ width (aref char-infos n)))) (setq right (max right (+ width (aref char-infos (index1+ n))))) (incf width (aref char-infos (index+ 2 n))) (setq ascent (max ascent (aref char-infos (index+ 3 n)))) (setq descent (max descent (aref char-infos (index+ 4 n))))) )))) ))))) ;;----------------------------------------------------------------------------- ;; This controls the element size of the dst buffer given to translate. If ;; :default is specified, the size will be based on the current font, if known, ;; and otherwise 16 will be used. [An alternative would be to pass the buffer ;; size to translate, and allow it to return the desired size if it doesn't ;; like the current size. The problem is that the protocol doesn't allow ;; switching within a single request, so to allow switching would require ;; knowing the width of text, which isn't necessarily known. We could call ;; text-width to compute it, but perhaps that is doing too many favors?] [An ;; additional possibility is to allow an index-size of :two-byte, in which case ;; translate would be given a double-length 8-bit array, and translate would be ;; expected to store first-byte/second-byte instead of 16-bit integers.] (deftype index-size () '(member :default 8 16)) ;; In the functions below, if width is specified, it is assumed to be the total ;; pixel width of whatever string of glyphs is actually drawn. Specifying ;; width will allow for appending the output of subsequent calls to the same ;; protocol request, provided gcontext has not been modified in the interim. ;; If width is not specified, appending of subsequent output might not occur ;; (unless translate returns the width). Specifying width is simply a hint, ;; for performance. (defun draw-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) (opcode +x-polytext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) (funcall (or translate #'translate-default) vector 0 1 (gcontext-font gcontext nil) vector 1) ;; Allow translate to set a new font (when (type? new-font 'font) (setf (gcontext-font gcontext) new-font) (multiple-value-setq (new-start new-font translate-width) (funcall translate vector 0 1 new-font vector 1))) ;; If new-start is zero, translate refuses to output it (setq result (index-plusp new-start) elt (aref vector 1)) (deallocate-gcontext-state vector) (when translate-width (setq width translate-width)))) (when result (when (eql size 16) (setq opcode +x-polytext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) (gcontext gcontext) (int16 x y) (card8 1 0) (card8 (ldb (byte 8 0) elt)) (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-glyphs (drawable gcontext x y sequence &key (start 0) end translate width (size :default)) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (unless end (setq end (length sequence))) (ecase size ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end (or translate #'translate-default) width)) (16 (draw-glyphs16 drawable gcontext x y sequence start end (or translate #'translate-default) width)))) (defun draw-glyphs8 (drawable gcontext x y sequence start end translate width) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) (length (index- src-end src-start)) (request-length (* length 2)) ; Leave lots of room for font shifts. (display (gcontext-display gcontext)) (font (gcontext-font gcontext nil))) (declare (type array-index src-start src-end length) (type (or null array-index) next-start) (type display display)) (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) (do* ((boffset (index+ buffer-boffset 16)) (src-chunk 0) (dst-chunk 0) (offset 0) (overall-width 0) (stop-p nil)) ((or stop-p (zerop length)) ;; Ensure terminated with zero bytes (do ((end (the array-index (lround boffset)))) ((index>= boffset end)) (setf (aref buffer-bbuf boffset) 0) (index-incf boffset)) (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) (setf (buffer-boffset display) boffset) (unless (index-zerop length) (setq next-start src-start)) (when overall-width (setq width overall-width))) (declare (type array-index src-chunk dst-chunk offset) (type (or null int32) overall-width) (type generalized-boolean stop-p)) (setq src-chunk (index-min length *max-string-size*)) (multiple-value-bind (new-start new-font translated-width) (funcall translate sequence src-start (index+ src-start src-chunk) font buffer-bbuf (index+ boffset 2)) (setq dst-chunk (index- new-start src-start) length (index- length dst-chunk) src-start new-start) (if translated-width (when overall-width (incf overall-width translated-width)) (setq overall-width nil)) (when (index-plusp dst-chunk) (setf (aref buffer-bbuf boffset) dst-chunk) (setf (aref buffer-bbuf (index+ boffset 1)) offset) (incf boffset (index+ dst-chunk 2))) (setq offset 0) (cond ((null new-font) ;; Don't stop if translate copied whole chunk (unless (index= src-chunk dst-chunk) (setq stop-p t))) ((integerp new-font) (setq offset new-font)) ((type? new-font 'font) (setq font new-font) (let ((font-id (font-id font)) (buffer-boffset boffset)) (declare (type resource-id font-id) (type array-index buffer-boffset)) ;; This changes the gcontext font in the server ;; Update the gcontext cache (both local and server state) (let ((local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext))) (declare (type gcontext-state local-state server-state)) (setf (gcontext-internal-font-obj server-state) font (gcontext-internal-font server-state) font-id) (without-interrupts (setf (gcontext-internal-font-obj local-state) font (gcontext-internal-font local-state) font-id))) (card8-put 0 #xff) (card8-put 1 (ldb (byte 8 24) font-id)) (card8-put 2 (ldb (byte 8 16) font-id)) (card8-put 3 (ldb (byte 8 8) font-id)) (card8-put 4 (ldb (byte 8 0) font-id))) (index-incf boffset 5))) ))))) (values next-start width))) ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer ;; on 16bit boundaries and this function garbles the bytes. (defun draw-glyphs16 (drawable gcontext x y sequence start end translate width) ;; First result is new start, if end was not reached. Second result is ;; overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (clx-values (or null array-index) (or null int32))) (declare (type translation-function translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (let* ((src-start start) (src-end (or end (length sequence))) (next-start nil) (length (index- src-end src-start)) (request-length (* length 3)) ; Leave lots of room for font shifts. (display (gcontext-display gcontext)) (font (gcontext-font gcontext nil)) (buffer (display-tbuf16 display))) (declare (type array-index src-start src-end length) (type (or null array-index) next-start) (type display display) (type buffer-text16 buffer)) (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) (do* ((boffset (index+ buffer-boffset 16)) (src-chunk 0) (dst-chunk 0) (offset 0) (overall-width 0) (stop-p nil)) ((or stop-p (zerop length)) ;; Ensure terminated with zero bytes (do ((end (lround boffset))) ((index>= boffset end)) (setf (aref buffer-bbuf boffset) 0) (index-incf boffset)) (length-put 2 (index-ash (index- boffset buffer-boffset) -2)) (setf (buffer-boffset display) boffset) (unless (zerop length) (setq next-start src-start)) (when overall-width (setq width overall-width))) (declare (type array-index boffset src-chunk dst-chunk offset) (type (or null int32) overall-width) (type generalized-boolean stop-p)) (setq src-chunk (index-min length *max-string-size*)) (multiple-value-bind (new-start new-font translated-width) (funcall translate sequence src-start (index+ src-start src-chunk) font buffer 0) (setq dst-chunk (index- new-start src-start) length (index- length dst-chunk) src-start new-start) (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk) (if translated-width (when overall-width (incf overall-width translated-width)) (setq overall-width nil)) (when (index-plusp dst-chunk) (setf (aref buffer-bbuf boffset) dst-chunk) (setf (aref buffer-bbuf (index+ boffset 1)) offset) (index-incf boffset (index+ dst-chunk dst-chunk 2))) (setq offset 0) (cond ((null new-font) ;; Don't stop if translate copied whole chunk (unless (index= src-chunk dst-chunk) (setq stop-p t))) ((integerp new-font) (setq offset new-font)) ((type? new-font 'font) (setq font new-font) (let ((font-id (font-id font)) (buffer-boffset boffset)) (declare (type resource-id font-id) (type array-index buffer-boffset)) ;; This changes the gcontext font in the SERVER ;; Update the gcontext cache (both local and server state) (let ((local-state (gcontext-local-state gcontext)) (server-state (gcontext-server-state gcontext))) (declare (type gcontext-state local-state server-state)) (setf (gcontext-internal-font-obj server-state) font (gcontext-internal-font server-state) font-id) (without-interrupts (setf (gcontext-internal-font-obj local-state) font (gcontext-internal-font local-state) font-id))) (card8-put 0 #xff) (card8-put 1 (ldb (byte 8 24) font-id)) (card8-put 2 (ldb (byte 8 16) font-id)) (card8-put 3 (ldb (byte 8 8) font-id)) (card8-put 4 (ldb (byte 8 0) font-id))) (index-incf boffset 5))) ))))) (values next-start width))) (defun draw-image-glyph (drawable gcontext x y elt &key translate width (size :default)) ;; Returns true if elt is output, nil if translate refuses to output it. ;; Second result is overall width, if known. An initial font change is ;; allowed from translate. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values generalized-boolean (or null int32))) (let* ((display (gcontext-display gcontext)) (result t) (opcode +x-imagetext8+)) (declare (type display display)) (let ((vector (allocate-gcontext-state))) (declare (type gcontext-state vector)) (setf (aref vector 0) elt) (multiple-value-bind (new-start new-font translate-width) (funcall (or translate #'translate-default) vector 0 1 (gcontext-font gcontext nil) vector 1) ;; Allow translate to set a new font (when (type? new-font 'font) (setf (gcontext-font gcontext) new-font) (multiple-value-setq (new-start new-font translate-width) (funcall translate vector 0 1 new-font vector 1))) ;; If new-start is zero, translate refuses to output it (setq result (index-plusp new-start) elt (aref vector 1)) (deallocate-gcontext-state vector) (when translate-width (setq width translate-width)))) (when result (when (eql size 16) (setq opcode +x-imagetext16+) (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt)))) (with-buffer-request (display opcode :gc-force gcontext) (drawable drawable) (gcontext gcontext) (data 1) ;; 1 character (int16 x y) (card8 (ldb (byte 8 0) elt)) (card8 (ldb (byte 8 8) elt))) (values t width)))) (defun draw-image-glyphs (drawable gcontext x y sequence &key (start 0) end translate width (size :default)) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type (or null array-index) end) (type sequence sequence) (type (or null int32) width) (type index-size size)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg #+Genera * #-Genera translate)) (declare (clx-values (or null array-index) (or null int32))) (setf end (index-min (index+ start 255) (or end (length sequence)))) (ecase size ((:default 8) (draw-image-glyphs8 drawable gcontext x y sequence start end translate width)) (16 (draw-image-glyphs16 drawable gcontext x y sequence start end translate width)))) (defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) (font (gcontext-font gcontext nil)) (font-change nil) (new-start) (translated-width) (chunk)) (nil) ;; forever (declare (type display display) (type array-index length) (type (or null array-index) new-start chunk)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) ;; Translate the sequence into the buffer (multiple-value-setq (new-start font translated-width) (funcall (or translate #'translate-default) sequence start end font buffer-bbuf (index+ buffer-boffset 16))) ;; Number of glyphs translated (setq chunk (index- new-start start)) ;; Check for initial font change (when (and (index-zerop chunk) (type? font 'font)) (setq font-change t) ;; Loop around changing font (return-from change-font)) ;; Quit when nothing translated (when (index-zerop chunk) (return-from draw-image-glyphs8 new-start)) ;; Update buffer pointers (data-put 1 chunk) (let ((blen (lround (index+ 16 chunk)))) (length-put 2 (index-ash blen -2)) (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs8 (values (if (index= chunk length) nil new-start) (or translated-width width)))))) (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width) ;; An initial font change is allowed from translate, but any subsequent font ;; change or horizontal motion will cause termination (because the protocol ;; doesn't support chaining). [Alternatively, font changes could be accepted ;; as long as they are accompanied with a width return value, or always ;; accept font changes and call text-width as required. However, horizontal ;; motion can't really be accepted, due to semantics.] First result is new ;; start, if end was not reached. Second result is overall width, if known. (declare (type drawable drawable) (type gcontext gcontext) (type int16 x y) (type array-index start) (type sequence sequence) (type (or null array-index) end) (type (or null int32) width)) (declare (type (or null translation-function) translate) #+clx-ansi-common-lisp (dynamic-extent translate) #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg translate)) (declare (clx-values (or null array-index) (or null int32))) (do* ((display (gcontext-display gcontext)) (length (index- end start)) (font (gcontext-font gcontext nil)) (font-change nil) (new-start) (translated-width) (chunk) (buffer (buffer-tbuf16 display))) (nil) ;; forever (declare (type display display) (type array-index length) (type (or null array-index) new-start chunk) (type buffer-text16 buffer)) (when font-change (setf (gcontext-font gcontext) font)) (block change-font (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length) (drawable drawable) (gcontext gcontext) (int16 x y) (progn ;; Don't let any flushes happen since we manually set the request ;; length when we're done. (with-buffer-flush-inhibited (display) ;; Translate the sequence into the buffer (multiple-value-setq (new-start font translated-width) (funcall (or translate #'translate-default) sequence start end font buffer 0)) ;; Number of glyphs translated (setq chunk (index- new-start start)) ;; Check for initial font change (when (and (index-zerop chunk) (type? font 'font)) (setq font-change t) ;; Loop around changing font (return-from change-font)) ;; Quit when nothing translated (when (index-zerop chunk) (return-from draw-image-glyphs16 new-start)) (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk) ;; Update buffer pointers (data-put 1 chunk) (let ((blen (lround (index+ 16 (index-ash chunk 1))))) (length-put 2 (index-ash blen -2)) (setf (buffer-boffset display) (index+ buffer-boffset blen)))))) ;; Normal exit (return-from draw-image-glyphs16 (values (if (index= chunk length) nil new-start) (or translated-width width)))))) ;;----------------------------------------------------------------------------- (defun display-keycode-range (display) (declare (type display display)) (declare (clx-values min max)) (values (display-min-keycode display) (display-max-keycode display))) ;; Should this signal device-busy like the pointer-mapping setf, and return a ;; generalized-boolean instead (true for success)? Alternatively, should the ;; pointer-mapping setf be changed to set-pointer-mapping with a (member ;; :success :busy) result? (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5) ;; Setf ought to allow multiple values. (declare (type display display) (type sequence shift lock control mod1 mod2 mod3 mod4 mod5)) (declare (clx-values (member :success :busy :failed))) (let* ((keycodes-per-modifier (index-max (length shift) (length lock) (length control) (length mod1) (length mod2) (length mod3) (length mod4) (length mod5))) (data (make-array (index* 8 keycodes-per-modifier) :element-type 'card8 :initial-element 0))) (replace data shift) (replace data lock :start1 keycodes-per-modifier) (replace data control :start1 (index* 2 keycodes-per-modifier)) (replace data mod1 :start1 (index* 3 keycodes-per-modifier)) (replace data mod2 :start1 (index* 4 keycodes-per-modifier)) (replace data mod3 :start1 (index* 5 keycodes-per-modifier)) (replace data mod4 :start1 (index* 6 keycodes-per-modifier)) (replace data mod5 :start1 (index* 7 keycodes-per-modifier)) (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8) ((data keycodes-per-modifier) ((sequence :format card8) data)) (values (member8-get 1 :success :busy :failed))))) (defun modifier-mapping (display) ;; each value is a list of integers (declare (type display display)) (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)) (let ((lists nil)) (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8) () (do* ((keycodes-per-modifier (card8-get 1)) (advance-by +replysize+ keycodes-per-modifier) (keys nil nil) (i 0 (index+ i 1))) ((index= i 8)) (advance-buffer-offset advance-by) (dotimes (j keycodes-per-modifier) (let ((key (read-card8 j))) (unless (zerop key) (push key keys)))) (push (nreverse keys) lists))) (values-list (nreverse lists)))) ;; Either we will want lots of defconstants for well-known values, or perhaps ;; an integer-to-keyword translation function for well-known values. (defun change-keyboard-mapping (display keysyms &key (start 0) end (first-keycode start)) ;; start/end give subrange of keysyms ;; first-keycode is the first-keycode to store at (declare (type display display) (type array-index start) (type card8 first-keycode) (type (or null array-index) end) (type (array * (* *)) keysyms)) (let* ((keycode-end (or end (array-dimension keysyms 0))) (keysyms-per-keycode (array-dimension keysyms 1)) (length (index- keycode-end start)) (size (index* length keysyms-per-keycode)) (request-length (index+ size 2))) (declare (type array-index keycode-end keysyms-per-keycode length request-length)) (with-buffer-request (display +x-setkeyboardmapping+ :length (index-ash request-length 2) :sizes (32)) (data length) (length request-length) (card8 first-keycode keysyms-per-keycode) (progn (do ((limit (index-ash (buffer-size display) -2)) (w (index+ 2 (index-ash buffer-boffset -2))) (i start (index+ i 1))) ((index>= i keycode-end) (setf (buffer-boffset display) (index-ash w 2))) (declare (type array-index limit w i)) (when (index> w limit) (buffer-flush display) (setq w (index-ash (buffer-boffset display) -2))) (do ((j 0 (index+ j 1))) ((index>= j keysyms-per-keycode)) (declare (type array-index j)) (card29-put (index* w 4) (aref keysyms i j)) (index-incf w))))))) (defun keyboard-mapping (display &key first-keycode start end data) ;; First-keycode specifies which keycode to start at (defaults to min-keycode). ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode) ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)). ;; If DATA is specified, the results are put there. (declare (type display display) (type (or null card8) first-keycode) (type (or null array-index) start end) (type (or null (array * (* *))) data)) (declare (clx-values (array * (* *)))) (unless first-keycode (setq first-keycode (display-min-keycode display))) (unless start (setq start first-keycode)) (unless end (setq end (1+ (display-max-keycode display)))) (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32)) ((card8 first-keycode (index- end start))) (do* ((keysyms-per-keycode (card8-get 1)) (bytes-per-keycode (* keysyms-per-keycode 4)) (advance-by +replysize+ bytes-per-keycode) (keycode-count (floor (card32-get 4) keysyms-per-keycode) (index- keycode-count 1)) (result (if (and (arrayp data) (= (array-rank data) 2) (>= (array-dimension data 0) (index+ start keycode-count)) (>= (array-dimension data 1) keysyms-per-keycode)) data (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode) :element-type 'keysym :initial-element 0))) (i start (1+ i))) ((zerop keycode-count) (setq data result)) (advance-buffer-offset advance-by) (dotimes (j keysyms-per-keycode) (setf (aref result i j) (card29-get (* j 4)))))) data) cmucl-21a/src/clx/translate.lisp000066400000000000000000000570161260377556400170350ustar00rootroot00000000000000;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1987 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; #+cmu (ext:file-comment "$Id: translate.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym) (defun define-keysym-set (set first-keysym last-keysym) ;; Define all keysyms from first-keysym up to and including ;; last-keysym to be in SET (returned from the keysym-set function). ;; Signals an error if the keysym range overlaps an existing set. (declare (type keyword set) (type keysym first-keysym last-keysym)) (when (> first-keysym last-keysym) (rotatef first-keysym last-keysym)) (setq *keysym-sets* (delete set *keysym-sets* :key #'car)) (dolist (set *keysym-sets*) (let ((first (second set)) (last (third set))) (when (or (<= first first-keysym last) (<= first last-keysym last)) (error "Keysym range overlaps existing set ~s" set)))) (push (list set first-keysym last-keysym) *keysym-sets*) set) (defun keysym-set (keysym) ;; Return the character code set name of keysym (declare (type keysym keysym) (clx-values keyword)) (dolist (set *keysym-sets*) (let ((first (second set)) (last (third set))) (when (<= first keysym last) (return (first set)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro keysym (keysym &rest bytes) ;; Build a keysym. ;; ;; If KEYSYM is an integer, it is used as the most significant ;; bits of the keysym, and BYTES are used to specify low order ;; bytes. The last parameter is always byte4 of the keysym. If ;; KEYSYM is not an integer, the keysym associated with KEYSYM is ;; returned. ;; ;; This is a macro and not a function macro to promote ;; compile-time lookup. All arguments are evaluated. ;; ;; FIXME: The above means that this shouldn't really be a macro at ;; all, but a compiler macro. Probably, anyway. (declare (type t keysym) (type list bytes) (clx-values keysym)) (typecase keysym ((integer 0 *) (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b)))) (otherwise (or (car (character->keysyms keysym)) (error "~s Isn't the name of a keysym" keysym)))))) (defvar *keysym->character-map* (make-hash-table :test (keysym->character-map-test) :size 400)) ;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask) ;; With the following accessor macros. Everything after OBJECT is optional. (defmacro keysym-mapping-object (keysym-mapping) ;; Parameter to translate `(first ,keysym-mapping)) (defmacro keysym-mapping-translate (keysym-mapping) ;; Function to be called with parameters (display state OBJECT) ;; when translating KEYSYM and modifiers and mask are satisfied. `(second ,keysym-mapping)) (defmacro keysym-mapping-lowercase (keysym-mapping) ;; LOWERCASE is used for uppercase alphabetic keysyms. The value ;; is the associated lowercase keysym. `(third ,keysym-mapping)) (defmacro keysym-mapping-modifiers (keysym-mapping) ;; MODIFIERS is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying when to use this ;; keysym-translation. `(fourth ,keysym-mapping)) (defmacro keysym-mapping-mask (keysym-mapping) ;; MASK is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying which modifiers to look at ;; (i.e. modifiers not specified are don't-cares) `(fifth ,keysym-mapping)) (defvar *default-keysym-translate-mask* (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) (logand #xff (lognot (make-state-mask :lock)))) "Default keysym state mask to use during keysym-translation.") (defun define-keysym (object keysym &key lowercase translate modifiers mask display) ;; Define the translation from keysym/modifiers to a (usually ;; character) object. ANy previous keysym definition with ;; KEYSYM and MODIFIERS is deleted before adding the new definition. ;; ;; MODIFIERS is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying when to use this ;; keysym-translation. The default is NIL. ;; ;; MASK is either a modifier-mask or list containing intermixed ;; keysyms and state-mask-keys specifying which modifiers to look at ;; (i.e. modifiers not specified are don't-cares). ;; If mask is :MODIFIERS then the mask is the same as the modifiers ;; (i.e. modifiers not specified by modifiers are don't cares) ;; The default mask is *default-keysym-translate-mask* ;; ;; If DISPLAY is specified, the translation will be local to DISPLAY, ;; otherwise it will be the default translation for all displays. ;; ;; LOWERCASE is used for uppercase alphabetic keysyms. The value ;; is the associated lowercase keysym. This information is used ;; by the keysym-both-case-p predicate (for caps-lock computations) ;; and by the keysym-downcase function. ;; ;; TRANSLATE will be called with parameters (display state OBJECT) ;; when translating KEYSYM and modifiers and mask are satisfied. ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*)) ;; (or modifiers 0))) ;; when mask and modifiers aren't lists of keysyms] ;; The default is #'default-keysym-translate ;; (declare (type (or base-char t) object) (type keysym keysym) (type (or null mask16 (clx-list (or keysym state-mask-key))) modifiers) (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key))) mask) (type (or null display) display) (type (or null keysym) lowercase) (type (or null (function (display card16 t) t)) translate)) (flet ((merge-keysym-mappings (new old) ;; Merge new keysym-mapping with list of old mappings. ;; Ensure that the mapping with no modifiers or mask comes first. (let* ((key (keysym-mapping-modifiers new)) (merge (delete key old :key #'cadddr :test #'equal))) (if key (nconc merge (list new)) (cons new merge)))) (mask-check (mask) (unless (or (numberp mask) (dolist (element mask t) (unless (or (find element +state-mask-vector+) (gethash element *keysym->character-map*)) (return nil)))) (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym))))))) (let ((entry ;; Create with a single LIST call, to ensure cdr-coding (cond (mask (unless (eq mask :modifiers) (mask-check mask)) (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers))) (error "Mask with no modifiers")) (list object translate lowercase modifiers mask)) (modifiers (mask-check modifiers) (list object translate lowercase modifiers)) (lowercase (list object translate lowercase)) (translate (list object translate)) (t (list object))))) (if display (let ((previous (assoc keysym (display-keysym-translation display)))) (if previous (setf (cdr previous) (merge-keysym-mappings entry (cdr previous))) (push (list keysym entry) (display-keysym-translation display)))) (setf (gethash keysym *keysym->character-map*) (merge-keysym-mappings entry (gethash keysym *keysym->character-map*))))) object)) (defun undefine-keysym (object keysym &key display modifiers &allow-other-keys) ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS. ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists. (declare (type (or base-char t) object) (type keysym keysym) (type (or null mask16 (clx-list (or keysym state-mask-key))) modifiers) (type (or null display) display)) (flet ((match (key entry) (let ((object (car key)) (modifiers (cdr key))) (or (eql object (keysym-mapping-object entry)) (equal modifiers (keysym-mapping-modifiers entry)))))) (let* (entry (previous (if display (cdr (setq entry (assoc keysym (display-keysym-translation display)))) (gethash keysym *keysym->character-map*))) (key (cons object modifiers))) (when (and previous (find key previous :test #'match)) (setq previous (delete key previous :test #'match)) (if display (setf (cdr entry) previous) (setf (gethash keysym *keysym->character-map*) previous)))))) (defun keysym-downcase (keysym) ;; If keysym has a lower-case equivalent, return it, otherwise return keysym. (declare (type keysym keysym)) (declare (clx-values keysym)) (let ((translations (gethash keysym *keysym->character-map*))) (or (and translations (keysym-mapping-lowercase (first translations))) keysym))) (defun keysym-uppercase-alphabetic-p (keysym) ;; Returns T if keysym is uppercase-alphabetic. ;; I.E. If it has a lowercase equivalent. (declare (type keysym keysym)) (declare (clx-values (or null keysym))) (let ((translations (gethash keysym *keysym->character-map*))) (and translations (keysym-mapping-lowercase (first translations))))) (defun character->keysyms (character &optional display) ;; Given a character, return a list of all matching keysyms. ;; If DISPLAY is given, translations specific to DISPLAY are used, ;; otherwise only global translations are used. ;; Implementation dependent function. ;; May be slow [i.e. do a linear search over all known keysyms] (declare (type t character) (type (or null display) display) (clx-values (clx-list keysym))) (let ((result nil)) (when display (dolist (mapping (display-keysym-translation display)) (when (eql character (second mapping)) (push (first mapping) result)))) (maphash #'(lambda (keysym mappings) (dolist (mapping mappings) (when (eql (keysym-mapping-object mapping) character) (pushnew keysym result)))) *keysym->character-map*) result)) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant character-set-switch-keysym (keysym 255 126)) (defconstant left-shift-keysym (keysym 255 225)) (defconstant right-shift-keysym (keysym 255 226)) (defconstant left-control-keysym (keysym 255 227)) (defconstant right-control-keysym (keysym 255 228)) (defconstant caps-lock-keysym (keysym 255 229)) (defconstant shift-lock-keysym (keysym 255 230)) (defconstant left-meta-keysym (keysym 255 231)) (defconstant right-meta-keysym (keysym 255 232)) (defconstant left-alt-keysym (keysym 255 233)) (defconstant right-alt-keysym (keysym 255 234)) (defconstant left-super-keysym (keysym 255 235)) (defconstant right-super-keysym (keysym 255 236)) (defconstant left-hyper-keysym (keysym 255 237)) (defconstant right-hyper-keysym (keysym 255 238))) ;;----------------------------------------------------------------------------- ;; Keysym mapping functions (defun display-keyboard-mapping (display) (declare (type display display)) (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))) (or (display-keysym-mapping display) (setf (display-keysym-mapping display) (keyboard-mapping display)))) (defun keycode->keysym (display keycode keysym-index) (declare (type display display) (type card8 keycode) (type card8 keysym-index) (clx-values keysym)) (let* ((mapping (display-keyboard-mapping display)) (keysym (aref mapping keycode keysym-index))) (declare (type (simple-array keysym (* *)) mapping) (type keysym keysym)) ;; The keysym-mapping is brain dammaged. ;; Mappings for both-case alphabetic characters have the ;; entry for keysym-index zero set to the uppercase keysym ;; (this is normally where the lowercase keysym goes), and the ;; entry for keysym-index one is zero. (cond ((zerop keysym-index) ; Lowercase alphabetic keysyms (keysym-downcase keysym)) ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym (aref mapping keycode 0)) (t keysym)))) (defun keysym->character (display keysym &optional (state 0)) ;; Find the character associated with a keysym. ;; STATE can be used to set character attributes. ;; Implementation dependent function. (declare (type display display) (type keysym keysym) (type card16 state)) (declare (clx-values (or null character))) (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display)))) (mapping (or ;; Find the matching display mapping (dolist (mapping display-mappings) (when (mapping-matches-p display state mapping) (return mapping))) ;; Find the matching static mapping (dolist (mapping (gethash keysym *keysym->character-map*)) (when (mapping-matches-p display state mapping) (return mapping)))))) (when mapping (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate) display state (keysym-mapping-object mapping))))) (defun mapping-matches-p (display state mapping) ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY (declare (type display display) (type mask16 state) (type list mapping)) (declare (clx-values generalized-boolean)) (flet ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0)) ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask. ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified, ;; otherwise ignore unknown modifiers. (declare (type list display-mapping) ; Alist of (keysym . mask) (type (or mask16 list) modifiers) (type mask16 mask)) (declare (clx-values (or null mask16))) (if (numberp modifiers) modifiers (dolist (modifier modifiers mask) (declare (type symbol modifier)) (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq))) (setq mask (logior mask (if bit (ash 1 bit) (or (cdr (assoc modifier display-mapping)) ;; bad modifier (if errorp (return-from modifiers->mask nil) 0)))))))))) (let* ((display-mapping (get-display-modifier-mapping display)) (mapping-modifiers (keysym-mapping-modifiers mapping)) (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t) (return-from mapping-matches-p nil))) (mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default. (if mapping-modifiers ; If no modifiers, match anything. *default-keysym-translate-mask* 0))) (mask (if (eq mapping-mask :modifiers) modifiers (modifiers->mask display-mapping mapping-mask nil)))) (declare (type mask16 modifiers mask)) (= (logand state mask) modifiers)))) (defun default-keysym-index (display keycode state) ;; Returns a keysym-index for use with keycode->character (declare (clx-values card8)) (macrolet ((keystate-p (state keyword) `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((mapping (display-keyboard-mapping display)) (keysyms-per-keycode (array-dimension mapping 1)) (symbolp (and (> keysyms-per-keycode 2) (state-keysymp display state character-set-switch-keysym))) (result (if symbolp 2 0))) (declare (type (simple-array keysym (* *)) mapping) (type generalized-boolean symbolp) (type card8 keysyms-per-keycode result)) (when (and (< result keysyms-per-keycode) (keysym-shift-p display state (keysym-uppercase-alphabetic-p (aref mapping keycode 0)))) (incf result)) result))) (defun keysym-shift-p (display state uppercase-alphabetic-p &key shift-lock-xors (control-modifiers '#.(list left-meta-keysym left-super-keysym left-hyper-keysym))) (declare (type display display) (type card16 state) (type generalized-boolean uppercase-alphabetic-p) (type generalized-boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same ;;; as neither if the character is alphabetic. (declare (clx-values generalized-boolean)) (macrolet ((keystate-p (state keyword) `(logbitp ,(position keyword +state-mask-vector+) ,state))) (let* ((controlp (or (keystate-p state :control) (dolist (modifier control-modifiers) (when (state-keysymp display state modifier) (return t))))) (shiftp (keystate-p state :shift)) (lockp (keystate-p state :lock)) (alphap (or uppercase-alphabetic-p (not (state-keysymp display #.(make-state-mask :lock) caps-lock-keysym))))) (declare (type generalized-boolean controlp shiftp lockp alphap)) ;; Control keys aren't affected by lock (unless controlp ;; Not a control character - check state of lock modifier (when (and lockp alphap (or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors (setq shiftp (not shiftp)))) shiftp))) ;;; default-keysym-index implements the following tables: ;;; ;;; control shift caps-lock character character ;;; 0 0 0 #\a #\8 ;;; 0 0 1 #\A #\8 ;;; 0 1 0 #\A #\* ;;; 0 1 1 #\A #\* ;;; 1 0 0 #\control-A #\control-8 ;;; 1 0 1 #\control-A #\control-8 ;;; 1 1 0 #\control-shift-a #\control-* ;;; 1 1 1 #\control-shift-a #\control-* ;;; ;;; control shift shift-lock character character ;;; 0 0 0 #\a #\8 ;;; 0 0 1 #\A #\* ;;; 0 1 0 #\A #\* ;;; 0 1 1 #\A #\8 ;;; 1 0 0 #\control-A #\control-8 ;;; 1 0 1 #\control-A #\control-* ;;; 1 1 0 #\control-shift-a #\control-* ;;; 1 1 1 #\control-shift-a #\control-8 (defun keycode->character (display keycode state &key keysym-index (keysym-index-function #'default-keysym-index)) ;; keysym-index defaults to the result of keysym-index-function which ;; is called with the following parameters: ;; (char0 state caps-lock-p keysyms-per-keycode) ;; where char0 is the "character" object associated with keysym-index 0 and ;; caps-lock-p is non-nil when the keysym associated with the lock ;; modifier is for caps-lock. ;; STATE can also used for setting character attributes. ;; Implementation dependent function. (declare (type display display) (type card8 keycode) (type card16 state) (type (or null card8) keysym-index) (type (or null (function (base-char card16 generalized-boolean card8) card8)) keysym-index-function)) (declare (clx-values (or null character))) (let* ((index (or keysym-index (funcall keysym-index-function display keycode state))) (keysym (if index (keycode->keysym display keycode index) 0))) (declare (type (or null card8) index) (type keysym keysym)) (when (plusp keysym) (keysym->character display keysym state)))) (defun get-display-modifier-mapping (display) (labels ((keysym-replace (display modifiers mask &aux result) (dolist (modifier modifiers result) (push (cons (keycode->keysym display modifier 0) mask) result)))) (or (display-modifier-mapping display) (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5) (modifier-mapping display) (setf (display-modifier-mapping display) (nconc (keysym-replace display shift #.(make-state-mask :shift)) (keysym-replace display lock #.(make-state-mask :lock)) (keysym-replace display control #.(make-state-mask :control)) (keysym-replace display mod1 #.(make-state-mask :mod-1)) (keysym-replace display mod2 #.(make-state-mask :mod-2)) (keysym-replace display mod3 #.(make-state-mask :mod-3)) (keysym-replace display mod4 #.(make-state-mask :mod-4)) (keysym-replace display mod5 #.(make-state-mask :mod-5)))))))) (defun state-keysymp (display state keysym) ;; Returns T when a modifier key associated with KEYSYM is on in STATE (declare (type display display) (type card16 state) (type keysym keysym)) (declare (clx-values generalized-boolean)) (let* ((mapping (get-display-modifier-mapping display)) (mask (assoc keysym mapping))) (and mask (plusp (logand state (cdr mask)))))) (defun mapping-notify (display request start count) ;; Called on a mapping-notify event to update ;; the keyboard-mapping cache in DISPLAY (declare (type display display) (type (member :modifier :keyboard :pointer) request) (type card8 start count) (ignore count start)) ;; Invalidate the keyboard mapping to force the next key translation to get it (case request (:modifier (setf (display-modifier-mapping display) nil)) (:keyboard (setf (display-keysym-mapping display) nil)))) (defun keysym-in-map-p (display keysym keymap) ;; Returns T if keysym is found in keymap (declare (type display display) (type keysym keysym) (type (bit-vector 256) keymap)) (declare (clx-values generalized-boolean)) ;; The keysym may appear in the keymap more than once, ;; So we have to search the entire keysym map. (do* ((min (display-min-keycode display)) (max (display-max-keycode display)) (map (display-keyboard-mapping display)) (jmax (min 2 (array-dimension map 1))) (i min (1+ i))) ((> i max)) (declare (type card8 min max jmax) (type (simple-array keysym (* *)) map)) (when (and (plusp (aref keymap i)) (dotimes (j jmax) (when (= keysym (aref map i j)) (return t)))) (return t)))) (defun character-in-map-p (display character keymap) ;; Implementation dependent function. ;; Returns T if character is found in keymap (declare (type display display) (type character character) (type (bit-vector 256) keymap)) (declare (clx-values generalized-boolean)) ;; Check all one bits in keymap (do* ((min (display-min-keycode display)) (max (display-max-keycode display)) (jmax (array-dimension (display-keyboard-mapping display) 1)) (i min (1+ i))) ((> i max)) (declare (type card8 min max jmax)) (when (and (plusp (aref keymap i)) ;; Match when character is in mapping for this keycode (dotimes (j jmax) (when (eql character (keycode->character display i 0 :keysym-index j)) (return t)))) (return t)))) (defun keysym->keycodes (display keysym) ;; Return keycodes for keysym, as multiple values (declare (type display display) (type keysym keysym)) (declare (clx-values (or null keycode) (or null keycode) (or null keycode))) ;; The keysym may appear in the keymap more than once, ;; So we have to search the entire keysym map. (do* ((min (display-min-keycode display)) (max (display-max-keycode display)) (map (display-keyboard-mapping display)) (jmax (min 2 (array-dimension map 1))) (i min (1+ i)) (result nil)) ((> i max) (values-list result)) (declare (type card8 min max jmax) (type (simple-array keysym (* *)) map)) (dotimes (j jmax) (when (= keysym (aref map i j)) (push i result))))) cmucl-21a/src/clx/xinerama.lisp000066400000000000000000000054771260377556400166500ustar00rootroot00000000000000;;; -*- Mode: Lisp -*- ;;; ;;; Copyright (C) 2008, Julian Stecklina ;;; ;;; (( ;;; )) This file is COFFEEWARE. As long as you retain this notice ;;; | |o) you can do whatever you want with this code. If you think, ;;; |___|jgs it's worth it, you may buy the author a coffee in return. ;;; ;;; Description: ;;; ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. (defpackage "XLIB.XINERAMA" (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" "WITH-BUFFER-REQUEST" "WITH-BUFFER-REQUEST-AND-REPLY" "DATA" "BOOLEAN" "BOOLEAN-GET" "CARD8" "CARD8-GET" "CARD16" "CARD16-GET" "CARD32" "CARD32-GET" "INT16" "INT16-GET") (:export "SCREEN-INFO" "SCREEN-INFO-NUMBER" "SCREEN-INFO-X" "SCREEN-INFO-Y" "SCREEN-INFO-WIDTH" "SCREEN-INFO-HEIGHT" "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) (in-package "XINERAMA") (define-extension "XINERAMA") (defun xinerama-opcode (display) (extension-opcode display "XINERAMA")) (defconstant +major-version+ 1) (defconstant +minor-version+ 1) (defconstant +get-version+ 0) (defconstant +get-state+ 1) (defconstant +get-screen-count+ 2) (defconstant +get-screen-size+ 3) (defconstant +is-active+ 4) (defconstant +query-screens+ 5) (defstruct screen-info (number 0 :type (unsigned-byte 32)) (x 0 :type (signed-byte 16)) (y 0 :type (signed-byte 16)) (width 0 :type (unsigned-byte 16)) (height 0 :type (unsigned-byte 16))) (defun xinerama-query-version (display) (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +get-version+) (card8 +major-version+) (card8 +minor-version+)) (values (card16-get 8) ; server major version (card16-get 10)))) ; server minor version (defun xinerama-is-active (display) "Returns T, iff Xinerama is supported and active." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +is-active+)) (values ;; XCB says this is actually a CARD32, but why?! (boolean-get 8)))) (defun xinerama-query-screens (display) "Returns a list of screen-info structures." (with-buffer-request-and-reply (display (xinerama-opcode display) nil) ((data +query-screens+)) (values (loop with index = 32 for number from 0 below (card32-get 8) collect (prog1 (make-screen-info :number number :x (int16-get index) :y (int16-get (+ index 2)) :width (card16-get (+ index 4)) :height (card16-get (+ index 6))) (incf index 8)))))) ;;; EOF cmucl-21a/src/clx/xrender.lisp000066400000000000000000001431151260377556400165030ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann #+cmu (ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann ;;; (c) copyright 2002 by Christian Sunesson ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; NOTE: we need to watch maximum request sizes and somehow work ;;; around them. Sometimes e.g. in AddGlyphs this is not possible, ;;; which is a design failure. ;;; TODO ;; - some request are still to be implemented at all. ;; + Can they not wait? Xrender seems to be in flux as the specification ;; isn't even conforming to the acctual protocol. However backwards ;; wierd that sound. --noss ;; - we need to invent something for the color values of e.g. ;; fill-rectangles; I would prefer some generic functions, so that ;; we later can map CLIM design directly to colors. ;; - we want some conviencene function to turn graphics contexts into ;; render pictures. --GB 2002-08-21 ;; - also: uniform-alpha-picture display alpha-value ;; uniform-color-picture display red green blue ;; --GB 2002-08-21 ;; - maybe we should aim for a higher level interface to ;; color-trapzoids and color-triangles and offer a low level [raw] ;; interface also for high performance apps? ;; - Write tests. ;;;; API issues ;; - On one hand we want convenience functions like RENDER-TRIANGLE or ;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to ;; write a full rasterization library you obviously want high ;; performance entry points as RENDER-TRIANGLES-1. ;; - We want to extend XLIB:COLOR into something with alpha channel. ;; How to name it? ;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body ;; ;; Example: ;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0) ;; (RENDER-TRIANGLE dest color ...)) ;; - Pose the filter and the transform slots of a picture. ;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT? ;; - COPY-PICTURE? ;; - WITH-PICTURE-OPTIONS ? ;; ;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...) ;; - WITH-PICTURE ? ;; ;; (WITH-PICTURE (picture drawable ...) ...) ;; (in-package :xlib) ;; Beginning to collect the external interface for documentation. (export '(render-create-picture render-free-picture render-create-glyph-set render-reference-glyph-set render-free-glyph-set render-add-glyph render-add-glyph-from-picture render-free-glyph render-fill-rectangle picture-format-display picture-format-id picture-format-type picture-format-depth picture-format-red-byte picture-format-green-byte picture-format-blue-byte picture-format-alpha-byte picture-format-colormap ;; picture object picture-repeat picture-alpha-map picture-alpha-x-origin picture-alpha-y-origin picture-clip-x-origin picture-clip-y-origin picture-clip-mask picture-graphics-exposures picture-subwindow-mode picture-poly-edge picture-poly-mode picture-dither picture-component-alpha picture-drawable find-matching-picture-formats find-window-picture-format render-free-picture render-free-glyph-set render-query-version ;; render-query-picture-formats render-fill-rectangle render-composite render-create-glyph-set render-reference-glyph-set render-composite-glyphs render-add-glyph render-add-glyph-from-picture render-free-glyphs)) (pushnew :clx-ext-render *features*) (define-extension "RENDER") ;;;; Request constants ;; Note: Although version numbers are given render.h where the request ;; numbers are defined, render-query-version returns 0.0 all displays ;; i tested. --GB 2004-07-21 (defconstant +X-RenderQueryVersion+ 0) ;done (defconstant +X-RenderQueryPictFormats+ 1) (defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7 (defconstant +X-RenderQueryDithers+ 3) (defconstant +X-RenderCreatePicture+ 4) ;done (defconstant +X-RenderChangePicture+ 5) ;done (defconstant +X-RenderSetPictureClipRectangles+ 6) ;done (defconstant +X-RenderFreePicture+ 7) ;done (defconstant +X-RenderComposite+ 8) ;we need better arglist (defconstant +X-RenderScale+ 9) (defconstant +X-RenderTrapezoids+ 10) ;low-level done (defconstant +X-RenderTriangles+ 11) ;low-level done (defconstant +X-RenderTriStrip+ 12) (defconstant +X-RenderTriFan+ 13) (defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h (defconstant +X-RenderTransform+ 16) ;commented out in render.h (defconstant +X-RenderCreateGlyphSet+ 17) ;done (defconstant +X-RenderReferenceGlyphSet+ 18) ;done (defconstant +X-RenderFreeGlyphSet+ 19) ;done (defconstant +X-RenderAddGlyphs+ 20) ;done, untested (defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested (defconstant +X-RenderFreeGlyphs+ 22) ;done, untested (defconstant +X-RenderCompositeGlyphs8+ 23) ;done (defconstant +X-RenderCompositeGlyphs16+ 24) ;done (defconstant +X-RenderCompositeGlyphs32+ 25) ;done ;; >= 0.1 (defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done ;; >= 0.5 (defconstant +X-RenderCreateCursor+ 27) ;; >= 0.6 (defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do. (defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side ; some guts of its implementation there. (defconstant +X-RenderSetPictureFilter+ 30) (defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors? ;;;; ;; Sanity measures: ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. (defstruct render-info major-version minor-version picture-formats) (defun display-render-info (display) (getf (xlib:display-plist display) 'render-info)) (defun (setf display-render-info) (new-value display) (setf (getf (xlib:display-plist display) 'render-info) new-value)) (defun ensure-render-initialized (display) "Ensures that the RENDER extension is initialized. Should be called by every function, which attempts to generate RENDER requests." ;; xxx locking? (unless (display-render-info display) (let ((q (make-render-info))) (multiple-value-bind (maj min) (render-query-version display) (setf (render-info-major-version q) maj (render-info-minor-version q) min) (setf (render-info-picture-formats q) (make-hash-table :test #'eql)) (dolist (pf (render-query-picture-formats display)) (setf (gethash (picture-format-id pf) (render-info-picture-formats q)) pf)) (setf (display-render-info display) q))))) (defun find-matching-picture-formats (display &key depth-min depth-max depth red-min red-max red green-min green-max green blue-min blue-max blue alpha-min alpha-max alpha type colormap) ;; (ensure-render-initialized display) (let ((res nil)) (maphash (lambda (k f) (declare (ignore k)) (when (and (or (null type) (eql (picture-format-type f) type)) (or (null colormap) (eql (picture-format-colormap f) colormap)) ;; min (or (null depth-min) (>= (picture-format-depth f) depth-min)) (or (null red-min) (>= (byte-size (picture-format-red-byte f)) red-min)) (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min)) (or (null blue-min) (>= (byte-size (picture-format-blue-byte f)) blue-min)) (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min)) ;; max (or (null depth-max) (<= (picture-format-depth f) depth-max)) (or (null red-max) (<= (byte-size (picture-format-red-byte f)) red-max)) (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max)) (or (null blue-max) (<= (byte-size (picture-format-blue-byte f)) blue-max)) (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max)) ;; match (or (null depth) (= (picture-format-depth f) depth)) (or (null red) (= (byte-size (picture-format-red-byte f)) red)) (or (null green) (= (byte-size (picture-format-green-byte f)) green)) (or (null blue) (= (byte-size (picture-format-blue-byte f)) blue)) (or (null alpha) (= (byte-size (picture-format-alpha-byte f)) alpha))) (pushnew f res))) (render-info-picture-formats (display-render-info display))) res)) (defun find-window-picture-format (window) "Find the picture format which matches the given window." (let* ((vi (window-visual-info window)) (display (window-display window))) (ensure-render-initialized display) (case (visual-info-class vi) ((:true-color) (maphash (lambda (k f) (declare (ignore k)) (when (and (eql (picture-format-type f) :direct) (eql (picture-format-depth f) (drawable-depth window)) (eql (dpb -1 (picture-format-red-byte f) 0) (visual-info-red-mask vi)) (eql (dpb -1 (picture-format-green-byte f) 0) (visual-info-green-mask vi)) (eql (dpb -1 (picture-format-blue-byte f) 0) (visual-info-blue-mask vi)) (eql (byte-size (picture-format-alpha-byte f)) 0)) (return-from find-window-picture-format f))) (render-info-picture-formats (display-render-info display)))) (t )))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (picture-id ,thing)))) (define-accessor glyph-set (32) ((index) index :blip) ((index thing) `(resource-id-put ,index (glyph-set-id ,thing))))) ;;; picture format (defstruct picture-format display (id 0 :type (unsigned-byte 29)) type depth red-byte green-byte blue-byte alpha-byte colormap) (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) ;; build an abbreviated representation of the format (let ((bytes (sort (list (cons "r" (picture-format-red-byte object)) (cons "g" (picture-format-green-byte object)) (cons "b" (picture-format-blue-byte object)) (cons "a" (picture-format-alpha-byte object))) #'> :key #'(lambda (x) (byte-position (cdr x)))))) (dolist (k bytes) (unless (zerop (byte-size (cdr k))) (format bag " ~A~D" (car k) (byte-size (cdr k))))))))) (print-unreadable-object (object stream :type t :identity nil) (format stream "~D ~S ~S ~S~A" (picture-format-id object) (picture-format-colormap object) (picture-format-depth object) (picture-format-type object) abbrev)))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-accessor picture-format (32) ((index) `(gethash (read-card32 ,index) (render-info-picture-formats (display-render-info .display.)))) ((index thing) `(write-card32 ,index (picture-format-id ,thing)))) (define-accessor render-op (8) ((index) `(member8-get ,index :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor)) ((index thing) `(member8-put ,index ,thing :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) (deftype render-op () '(member :clear :src :dst :over :over-reverse :in :in-reverse :out :out-reverse :atop :atop-reverse :xor :add :saturate :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over :disjoint-over-reverse :disjoint-in :disjoint-in-reverse :disjoint-out :disjoint-out-reverse :disjoint-atop :disjoint-atop-reverse :disjoint-xor :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over :conjoint-over-reverse :conjoint-in :conjoint-in-reverse :conjoint-out :conjoint-out-reverse :conjoint-atop :conjoint-atop-reverse :conjoint-xor))) ;; Now these pictures objects are like graphics contexts. I was about ;; to introduce a synchronous mode, realizing that the RENDER protocol ;; provides no provision to actually query a picture object's values. ;; *sigh* (def-clx-class (picture (:copier nil)) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format) (%changed-p) (%server-values) (%values) (%drawable)) (defun picture-drawable (picture) (picture-%drawable picture)) ;; xx make id, display, format readonly (defun %render-change-picture-clip-rectangles (picture rectangles) "Dont call me, use (SETF PICTURE-CLIP-MASK) instead." (declare (optimize (speed 0))) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureClipRectangles+) (picture picture) (int16 (picture-clip-x-origin picture)) (int16 (picture-clip-y-origin picture)) ((sequence :format int16) rectangles)))) (macrolet ((foo (&rest specs) `(progn ,@(loop for (type slot default) in specs for index from 0 collect `(progn (defun ,(xintern 'picture- slot) (picture) (aref (picture-%values picture) ,index)) (defun (setf ,(xintern 'picture- slot)) (new-value picture) (setf (picture-%changed-p picture) t) (setf (aref (picture-%values picture) ,index) new-value)))) (defun synchronise-picture-state (picture) (when (picture-%changed-p picture) (let ((display (picture-display picture))) (ensure-render-initialized display) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderChangePicture+) (picture picture) (mask ,@(loop for (type slot default) in specs for index from 0 collect `(,type (and ,(cond ((eql slot 'clip-mask) `(not (typep (aref (picture-%values picture) ,index) 'sequence))) (t 't)) (not (eq (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index))) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))))))) ,(let ((index (position 'clip-mask specs :key #'second))) `(unless (eql (aref (picture-%values picture) ,index) (aref (picture-%server-values picture) ,index)) (%render-change-picture-clip-rectangles picture (aref (picture-%values picture) ,index)) (setf (aref (picture-%server-values picture) ,index) (aref (picture-%values picture) ,index)))) (setf (picture-%changed-p picture) nil))) (defun render-create-picture (drawable &key format (picture (make-picture :display (drawable-display drawable))) ,@(loop for (type slot default-value) in specs collect (cond ((eql slot 'clip-mask) `(clip-mask :none)) (t slot))) ) ;; xxx also offer to give a colormap instead of a picture-format ;; values! (let ((display (drawable-display drawable))) (ensure-render-initialized display) (unless format ;; xxx check for drawable being a window (setf format (find-window-picture-format drawable))) (let ((pid (allocate-resource-id display picture 'picture))) (setf (picture-id picture) pid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreatePicture+) (resource-id pid) (drawable drawable) (picture-format format) (mask ,@(loop for (type slot default) in specs collect (cond ((eql slot 'clip-mask) (list type `(and (not (typep clip-mask 'sequence)) clip-mask))) (t (list type slot))))))) (when (typep clip-mask 'sequence) (%render-change-picture-clip-rectangles picture clip-mask)) (setf (picture-format picture) format) (setf (picture-%server-values picture) (vector ,@(loop for (type slot default) in specs collect `(or ,slot ,default)))) (setf (picture-%values picture) (copy-seq (picture-%server-values picture))) (setf (picture-%drawable picture) drawable) picture)) (defconstant +picture-state-length+ ,(length specs)) ))) (foo ((member :off :on) repeat :off) ((or (member :none) picture) alpha-map :none) (int16 alpha-x-origin 0) (int16 alpha-y-origin 0) (int16 clip-x-origin 0) (int16 clip-y-origin 0) ;; ### Now that is not correct is it?: ((or (member :none) pixmap) clip-mask :none) ((member :off :on) graphics-exposures :on) ((member :clip-by-children :include-inferiors) subwindow-mode :clip-by-children) ((member :sharp :smooth) poly-edge :smooth) ((member :precise :imprecise) poly-mode :precise) ((or (member :none) #||xatom||#) dither :none) ((member :off :on) component-alpha :off))) (defun render-free-picture (picture) (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) (picture picture)))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) (glyph-set glyph-set)))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryVersion+) (card32 0) (card32 1)) (values (card32-get 8) (card32-get 12) ))) (defun render-query-picture-formats (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryPictFormats+)) (let ((n-picture-formats (card32-get 8)) (n-screens (card32-get 12)) (n-depths (card32-get 16)) (n-visuals (card32-get 20)) (n-subpixel (card32-get 24))) (declare (ignore n-screens n-depths n-visuals n-subpixel)) (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid))))))))) (defun render-fill-rectangle (picture op color x1 y1 w h) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) (render-op op) ;op (card8 0) ;pad (card16 0) ;pad (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. (defun render-triangles-1 (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. (macrolet ((guts () '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTriangles+) (render-op op) ;op (card8 0) ;pad (card16 0) ;pad (resource-id (picture-id source)) (resource-id (picture-id picture)) (picture-format format) (int16 src-x) (int16 src-y) ((sequence :format int32) coord-sequence) )))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence)) (guts))) (t (guts))))) #|| (defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1)) ...) ||# (defun render-set-picture-transform (picture a b c d e f p q r) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureTransform+) #| (card8 0) ;; render-op op) ;op (card8 0) ;pad (card16 0) ;pad |# (resource-id (picture-id picture)) (card32 a) (card32 b) (card32 c) (card32 d) (card32 e) (card32 f) (card32 p) (card32 q) (card32 r)))) (defun render-query-filters (drawable) (let ((display (drawable-display drawable))) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) ((data +X-RenderQueryFilters+) (drawable drawable)) (let* ((len (card32-get 4)) (n-aliases (card32-get 8)) (n-filters (card32-get 12)) (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4))))) (print (list :aliases (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2)))))) (print (list :foo len n-aliases n-filters (loop for i below len collect (card8-get (+ off 0 (* 4 i))) collect (card8-get (+ off 1 (* 4 i))) collect (card8-get (+ off 2 (* 4 i))) collect (card8-get (+ off 3 (* 4 i)))))) (print (labels ((grab-string (j) (let ((n (card8-get j))) (incf j) (values (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j))) j)))) (loop repeat n-filters collect (multiple-value-bind (s j) (grab-string off) (setf off j) (intern (string-upcase s) :keyword))))) #+NIL (loop for i below n-picture-formats collect (let ((off (+ (* 8 4) (* i 28)))) ;size of picture-format-info (make-picture-format :display display :id (card32-get (+ off 0)) :type (member8-get (+ off 4) :indexed :direct) :depth (card8-get (+ off 5)) :red-byte (byte (integer-length (card16-get (+ off 10))) (card16-get (+ off 8))) :green-byte (byte (integer-length (card16-get (+ off 14))) (card16-get (+ off 12))) :blue-byte (byte (integer-length (card16-get (+ off 18))) (card16-get (+ off 16))) :alpha-byte (byte (integer-length (card16-get (+ off 22))) (card16-get (+ off 20))) :colormap (let ((cmid (card32-get (+ off 24)))) (unless (zerop cmid) (lookup-colormap display cmid)))))))))) (defun render-set-filter (picture filter) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) (card16 0) ;pad ((sequence :format card8) (map 'vector #'char-code filter))))) #|| (defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over)) (render-triangles-1 destination op source ...) ) ||# (defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderTrapezoids+) (render-op op) ;op (card8 0) ;pad (card16 0) ;pad (resource-id (picture-id source)) (resource-id (picture-id picture)) ((or (member :none) picture-format) mask-format) (int16 src-x) (int16 src-y) ((sequence :format int32) coord-sequence) ))) (defun render-composite (op source mask dest src-x src-y mask-x mask-y dst-x dst-y width height) (let ((display (picture-display source))) (synchronise-picture-state source) (when mask (synchronise-picture-state mask)) (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) (render-op op) ;op (card8 0) ;pad (card16 0) ;pad (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) (int16 src-x) (int16 src-y) (int16 mask-x) (int16 mask-y) (int16 dst-x) (int16 dst-y) (card16 width) (card16 height)))) (def-clx-class (glyph-set (:copier nil) ) (id 0 :type resource-id) (display nil :type (or null display)) (plist nil :type list) ; Extension hook (format)) (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) format) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateGlyphSet+) (glyph-set glyph-set) (picture-format format)) glyph-set))) (defun render-reference-glyph-set (existing-glyph-set &key glyph-set) (let ((display (glyph-set-display existing-glyph-set))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) (gsid (setf (glyph-set-id glyph-set) (allocate-resource-id display glyph-set 'glyph-set)))) (declare (ignore gsid)) (setf (glyph-set-format glyph-set) (glyph-set-format existing-glyph-set)) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderReferenceGlyphSet+) (glyph-set glyph-set) (glyph-set existing-glyph-set)) glyph-set))) (defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) (when (stringp sequence) ;; lazy me, but then you should not confuse glyphs with ;; characters anyway. (setf sequence (map 'vector #'char-code sequence))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) (card8 0) (card16 0) ;padding (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt (card8 0) (card16 0) ;padding (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) (defmacro %render-composite-glyphs (opcode type transform display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end) (let ((size (ecase type (card8 1) (card16 2) (card32 4))) ;; FIXME: the last chunk for CARD8 can be 254. (chunksize (ecase type (card8 252) (card16 254) (card32 254)))) `(multiple-value-bind (nchunks leftover) (floor (- end start) ,chunksize) (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size))) (if (> leftover 0) (+ 8 (* 4 (ceiling (* leftover ,size) 4))) 0))) (request-length (+ 7 (/ payloadsize 4)))) (declare (integer request-length)) (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length)) (data ,opcode) (length request-length) (render-op ,alu) (card8 0) (card16 0) ;padding (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) (glyph-set ,glyph-set) (int16 ,src-x) (int16 ,src-y) (progn (let ((boffset (+ buffer-boffset 28)) (start ,start) (end ,end) (dest-x ,dest-x) (dest-y ,dest-y)) (dotimes (i nchunks) (set-buffer-offset boffset) (put-items (0) (card8 ,chunksize) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence)) (setq dest-x 0 dest-y 0) (incf boffset (+ 8 (* ,chunksize ,size))) (incf start ,chunksize)) (when (> leftover 0) (set-buffer-offset boffset) (put-items (0) (card8 leftover) (card8 0) (card16 0) (int16 dest-x) (int16 dest-y) ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence)) ;; padding? (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4))))) (setf (buffer-boffset ,display) boffset)))))))) (defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence &key (op :over) (alu op) ;for the fun of it (src-x 0) (src-y 0) (mask-format :none) (start 0) (end (length sequence))) ;; xxx do we want to go with some translate function as draw-glyphs? (declare (type array-index start end)) (let ((display (picture-display dest))) (ensure-render-initialized display) (synchronise-picture-state dest) (synchronise-picture-state source) ;; hmm find out the element size (typecase sequence ((array (unsigned-byte 8) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 16) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) ((array (unsigned-byte 32) (*)) (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (string (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8)) '+X-RenderCompositeGlyphs8+) ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+) ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+) (t (error "Wow!"))) #.(cond ((<= char-code-limit (expt 2 8)) 'card8) ((<= char-code-limit (expt 2 16)) 'card16) ((<= char-code-limit (expt 2 32)) 'card32) (t (error "Wow!"))) #'char-code display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)) (t ;; should we bother testing the array element type? (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 #'(lambda (elt) (if (characterp elt) (char-code elt) elt)) display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end))) )) ;; --- idea: Allow data to be an image to avoid unecessary consing? - noss (defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data) (let ((display (glyph-set-display glyph-set))) (ensure-render-initialized display) (let* ((w (array-dimension data 1)) (h (array-dimension data 0)) (bitmap-format (display-bitmap-format display)) (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) (let* ((byte-per-line (* 4 (ceiling (* w (picture-format-depth (glyph-set-format glyph-set))) 32))) (request-length (+ 28 (* h byte-per-line)))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) (length (ceiling request-length 4)) (glyph-set glyph-set) (card32 1) ;number glyphs (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) (int16 y-origin) (int16 x-advance) (int16 y-advance) (progn (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h byte-per-line ;padded bytes per line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture &key x-origin y-origin x-advance y-advance x y width height) ;; untested, the duplication of x-origin seems bogus. ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture. ;; and orgin advance would be properties of the defined glyph. (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphsFromPicture+) (glyph-set glyph-set) (picture picture) (card16 width) (card16 height) (card16 x-origin) (card16 y-origin) (card16 x-advance) (card16 y-advance) (card16 x) (card16 y)))) ;; untested (defun render-free-glyphs (glyph-set glyphs) "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)." (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphs+) (glyph-set glyph-set) ((sequence :format card32) glyphs)))) #|| ;;; -------------------------------------------------------------------------------- ;; testing code: (defun x (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (display dpy) (pf (find-window-picture-format win)) (pm (xlib:create-pixmap :depth (xlib:drawable-depth win) :drawable win :width 1 :height 1)) (pm.p (render-create-picture pm :format pf :repeat :on)) (win.p (render-create-picture win :format pf)) (gs (render-create-glyph-set (first (find-matching-picture-formats dpy :alpha 8 :red-max 0 :green-max 0 :blue-max 0))))) (xlib:clear-area win) (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100) (render-add-glyph gs 18 :data (make-array (list 3 3) :initial-contents '((255 000 000) (000 255 000) (000 000 255)) :element-type '(unsigned-byte 8)) :x-advance 4 :y-advance 0 :x-origin 0 :y-origin 0) (let ((w 50) (h 50)) (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0))) (dotimes (i w) (dotimes (j h) (setf (aref data i j) (* 3 i)))) (render-add-glyph gs 17 :data data :x-advance (+ w 2) :y-advance 0 :x-origin 0 :y-origin 0))) (render-composite-glyphs-8 win.p gs pm.p 200 330 (vector 17 18 18 17 17 17 17 17 17 17) :alu op ) ;; (display-finish-output dpy) (close-display dpy))))) (defun z (op) (let ((dpy (open-display ""))) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (fmt (first (find-matching-picture-formats dpy :red-min 8 :green-min 8 :blue-min 8 :alpha-min 8))) (px (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt) :drawable win)) (px.pic (render-create-picture px :format fmt)) (px.gc (xlib:create-gcontext :drawable px))) (xlib:clear-area win) ;; (render-fill-rectangle px.pic :src (list #x8000 #x0000 #x8000 #xFFFF) 0 0 256 256) (render-composite :src pic pic px.pic 350 350 350 350 0 0 256 256) ;; (render-fill-rectangle px.pic :over (list #x8000 #x8000 #x8000 #x8000) 0 0 100 100) (render-composite :src px.pic px.pic pic 0 0 0 0 350 350 256 256) (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800) (display-finish-output dpy)) (close-display dpy)))) ;;; ---------------------------------------------------------------------------------------------------- (defun y (op) (let ((dpy (open-display ""))) (render-query-version dpy) (unwind-protect (let* ((win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win)) (px (xlib:create-pixmap :drawable win :width 256 :height 256 :depth 32)) (px.gc (xlib:create-gcontext :drawable px))) (dotimes (x 256) (dotimes (y 256) (setf (xlib:gcontext-foreground px.gc) (dpb x (byte 8 24) (dpb y (byte 8 16) (dpb y (byte 8 8) y)))) (xlib:draw-point px px.gc x y) )) (xlib:clear-area win) (let ((q (render-create-picture px :format (first (find-matching-picture-formats dpy :depth 32 :alpha 8 :red 8 :green 8 :blue 8)) :component-alpha :on :repeat :off))) (render-composite op q q pic 0 0 0 0 100 100 400 400)) (let () ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200) (display-finish-output dpy))) (close-display dpy)))) (defun zz () (let* ((dpy (xlib:open-display "")) (win (screen-root (first (display-roots dpy)))) (pic (render-create-picture win))) (xlib:clear-area win) (setf (picture-clip-mask pic) (list 100 100 200 2000)) (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000) (display-finish-output dpy) (close-display dpy))) ||# ;;;; Cursors (defun render-create-cursor (picture &optional (x 0) (y 0)) (let ((display (picture-display picture))) (ensure-render-initialized display) (synchronise-picture-state picture) (let* ((cursor (make-cursor :display display)) (cid (allocate-resource-id display cursor 'cursor))) (setf (cursor-id cursor) cid) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCreateCursor+) (resource-id cid) (resource-id (picture-id picture)) (card16 x) (card16 y)) cursor))) cmucl-21a/src/clx/xtest.lisp000066400000000000000000000107711260377556400162040ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Implementation of the XTest extension as described by ;;; http://www.x.org/docs/Xext/xtest.pdf ;;; ;;; Written by Lionel Flandrin in july ;;; 2008 and placed in the public domain. ;;; ;;; TODO: ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... (defpackage :xtest (:use :common-lisp :xlib) (:import-from :xlib #:data #:card8 #:card8-get #:card16 #:card16-get #:card32 #:card32-get #:extension-opcode #:define-extension #:gcontext #:resource-id #:window-id #:cursor #:make-cursor #:with-buffer-request-and-reply #:with-buffer-request #:display) (:export ;; Constants #:+major-version+ #:+minor-version+ ;; Functions #:set-gc-context-of-gc #:get-version #:compare-cursor #:fake-motion-event #:fake-button-event #:fake-key-event #:grab-control)) (in-package :xtest) (define-extension "XTEST") (defmacro opcode (display) `(extension-opcode ,display "XTEST")) ;;; The version we implement (defconstant +major-version+ 2) (defconstant +minor-version+ 2) (defconstant +none+ 0) (defconstant +current-cursor+ 1) ;;; XTest opcodes (defconstant +get-version+ 0) (defconstant +compare-cursor+ 1) (defconstant +fake-input+ 2) (defconstant +grab-control+ 3) ;;; Fake events (defconstant +fake-key-press+ 2) (defconstant +fake-key-release+ 3) (defconstant +fake-button-press+ 4) (defconstant +fake-button-release+ 5) (defconstant +fake-motion-notify+ 6) ;;; Client operations (defun set-gc-context-of-gc (gcontext gcontext-id) (declare (type gcontext gcontext) (type resource-id gcontext-id)) (setf (gcontext-id gcontext) gcontext-id)) ;;; Server requests (defun get-version (display &optional (major +major-version+) (minor +minor-version+)) "Returns the major and minor version of the server's XTest implementation" (declare (type display display)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +get-version+) (card8 major) (card16 minor)) (values (card8-get 1) (card16-get 8)))) (defun compare-cursor (display window &optional (cursor-id +current-cursor+)) (declare (type display display) (type resource-id cursor-id) (type window window)) (with-buffer-request-and-reply (display (opcode display) nil) ((data +compare-cursor+) (resource-id (window-id window)) (resource-id cursor-id)) (values (card8-get 1)))) (defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0)) "Move the mouse pointer at coordinates (x, y). If :relative is t, the movement is relative to the pointer's current position" (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 +fake-motion-notify+) (card8 (if relative 1 0)) (pad16 0) (card32 delay) (card32 root-window-id) (pad32 0 0) (card16 x) (card16 y) (pad32 0 0))) (defun fake-button-event (display button pressed &key (delay 0)) "Send a fake button event (button pressed or released) to the server. Most of the time, button 1 is the left one, 2 the middle and 3 the right one but it's not always the case." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-button-press+ +fake-button-release+)) (card8 button) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun fake-key-event (display keycode pressed &key (delay 0)) "Send a fake key event (key pressed or released) to the server based on its keycode." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +fake-input+) (card8 (if pressed +fake-key-press+ +fake-key-release+)) (card8 keycode) (pad16 0) (card32 delay) (pad32 0 0 0 0 0 0))) (defun grab-control (display grab?) "Make the client grab the server, that is allow it to make requests even when another client grabs the server." (declare (type display display)) (with-buffer-request (display (opcode display)) (data +grab-control+) (card8 (if grab? 1 0)) (pad8 0) (pad16 0))) ;;; Local Variables: ;;; indent-tabs-mode: nil ;;; End: cmucl-21a/src/clx/xvidmode.lisp000066400000000000000000000707571260377556400166660ustar00rootroot00000000000000;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: XFree86 video mode extension ;;; Created: 2003 03 28 15:28 ;;; Author: Iban Hatchondo ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Iban Hatchondo ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION ;;; DESCRIPTION ;;; ;;; These functions provide an interface to the server extension ;;; XFree86-VidModeExtension which allows the video modes to be ;;; queried, adjusted dynamically and the mode switching to be ;;; controlled. ;;; [ personal notes ] ;;; ;;; The documentation on this extension is very poor, probably, ;;; because it is not an X standard nor an X project team spec. ;;; Because of that, it need to be tested on some XFree 3.3.6, ;;; and XFree 4.3.x to ensure that all request are correctly ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. #+cmu (ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") (in-package :xlib) (export '(mode-info mode-info-dotclock mode-info-hdisplay mode-info-hsyncstart mode-info-hsyncend mode-info-htotal mode-info-hskew mode-info-vdisplay mode-info-vsyncstart mode-info-vsyncend mode-info-vtotal mode-info-flags mode-info-privsize mode-info-private make-mode-info xfree86-vidmode-query-version xfree86-vidmode-set-client-version xfree86-vidmode-get-permissions xfree86-vidmode-mod-mode-line xfree86-vidmode-get-mode-line xfree86-vidmode-get-all-mode-lines xfree86-vidmode-add-mode-line xfree86-vidmode-delete-mode-line xfree86-vidmode-validate-mode-line xfree86-vidmode-get-gamma xfree86-vidmode-set-gamma xfree86-vidmode-get-gamma-ramp xfree86-vidmode-set-gamma-ramp xfree86-vidmode-get-gamma-ramp-size xfree86-vidmode-lock-mode-switch xfree86-vidmode-switch-to-mode xfree86-vidmode-switch-mode xfree86-vidmode-select-next-mode xfree86-vidmode-select-prev-mode xfree86-vidmode-get-monitor xfree86-vidmode-get-viewport xfree86-vidmode-set-viewport xfree86-vidmode-get-dotclocks) :xlib) ;; current version numbers ;; ;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm. ;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client. ;; major 2 == uses new protocol version in XFree86 4.0. (defconstant +xf86vidmode-major-version+ 2) (defconstant +xf86vidmode-minor-version+ 2) ;; requests number. (defconstant +query-version+ 0) (defconstant +get-mode-line+ 1) (defconstant +mod-mode-line+ 2) (defconstant +switch-mode+ 3) (defconstant +get-monitor+ 4) (defconstant +lock-mode-switch+ 5) (defconstant +get-all-mode-lines+ 6) (defconstant +add-mode-line+ 7) (defconstant +delete-mode-line+ 8) (defconstant +validate-mode-line+ 9) (defconstant +switch-to-mode+ 10) (defconstant +get-viewport+ 11) (defconstant +set-viewport+ 12) ;; new for version 2.x of this extension. (defconstant +get-dot-clocks+ 13) (defconstant +set-client-version+ 14) (defconstant +set-gamma+ 15) (defconstant +get-gamma+ 16) (defconstant +get-gamma-ramp+ 17) (defconstant +set-gamma-ramp+ 18) (defconstant +get-gamma-ramp-size+ 19) (defconstant +get-permisions+ 20) (define-extension "XFree86-VidModeExtension" :events (:xfree86-vidmode-notify) :errors (xf86-vidmode-bad-clock xf86-vidmode-bad-htimings xf86-vidmode-bad-vtimings xf86-vidmode-mode-unsuitable xf86-vidmode-extension-disabled xf86-vidmode-client-not-local xf86-vidmode-zoom-locked)) (define-condition xf86-vidmode-bad-clock (request-error) ()) (define-condition xf86-vidmode-bad-htimings (request-error) ()) (define-condition xf86-vidmode-bad-vtimings (request-error) ()) (define-condition xf86-vidmode-mode-unsuitable (request-error) ()) (define-condition xf86-vidmode-extension-disabled (request-error) ()) (define-condition xf86-vidmode-client-not-local (request-error) ()) (define-condition xf86-vidmode-zoom-locked (request-error) ()) (define-error xf86-vidmode-bad-clock decode-core-error) (define-error xf86-vidmode-bad-htimings decode-core-error) (define-error xf86-vidmode-bad-vtimings decode-core-error) (define-error xf86-vidmode-mode-unsuitable decode-core-error) (define-error xf86-vidmode-extension-disabled decode-core-error) (define-error xf86-vidmode-client-not-local decode-core-error) (define-error xf86-vidmode-zoom-locked decode-core-error) (declare-event :XFree86-VidMode-notify (card16 sequence) (window (window event-window)) ; the root window of event screen (int16 state) ; what happend (int16 kind) ; what happend (boolean forced-p) ; extents of a new region ((or null card32) time)) ; event timestamp (defstruct mode-info (dotclock 0 :type card32) (hdisplay 0 :type card16) (hsyncstart 0 :type card16) (hsyncend 0 :type card16) (htotal 0 :type card16) (hskew 0 :type card32) (vdisplay 0 :type card16) (vsyncstart 0 :type card16) (vsyncend 0 :type card16) (vtotal 0 :type card16) (flags 0 :type card32) (privsize 0 :type card32) (private nil :type sequence)) (defmacro vidmode-opcode (display) `(extension-opcode ,display "XFree86-VidModeExtension")) (declaim (inline screen-position)) (defun screen-position (screen display) (declare (type display display) (type screen screen)) (declare (clx-values position)) (let ((position (position screen (xlib:display-roots display)))) (if (not (numberp position)) (error "screen ~A not found in display ~A" screen display) position))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xfree86-vidmode-query-version (display) "Determine the version of the extension built into the server. return two values major-version and minor-version in that order." (declare (type display display)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes 16) ((data +query-version+)) (let ((major (card16-get 8)) (minor (card16-get 10))) (declare (type card16 major minor)) (when (>= major 2) (XFree86-VidMode-set-client-version display)) (values major minor)))) (defun xfree86-vidmode-set-client-version (display) (declare (type display display)) (with-buffer-request (display (vidmode-opcode display)) (data +set-client-version+) (card16 +xf86vidmode-major-version+) (card16 +xf86vidmode-minor-version+))) (defun xfree86-vidmode-get-permissions (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-permisions+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8)))) (defun xfree86-vidmode-mod-mode-line (display screen mode-line) "Change the settings of the current video mode provided the requested settings are valid (e.g. they don't exceed the capabilities of the monitor)." (declare (type display display) (type screen screen)) (let* ((major (xfree86-vidmode-query-version display)) (v (mode-info->v-card16 mode-line major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (display (vidmode-opcode display)) (data +mod-mode-line+) (card32 (screen-position screen display)) ((sequence :format card16 :start 2) v)))) (defun xfree86-vidmode-get-mode-line (display screen) "Query the settings for the currently selected video mode. return a mode-info structure fields with the server answer. If there are any server private values (currently only applicable to the S3 server) the function will store it into the returned structure." (declare (clx-values mode-info) (type display display) (type screen screen)) (let ((major (xfree86-vidmode-query-version display)) (offset 8)) (declare (type fixnum offset) (type card16 major)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-mode-line+) (card16 (screen-position screen display)) (card16 0)) (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card16-get (incf offset 2))) :vdisplay (card16-get (incf offset 2)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 4))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) mode-info)))) (defun xfree86-vidmode-get-all-mode-lines (dpy screen) "Returns a list containing all video modes (as mode-info structure). The first element of the list corresponds to the current video mode." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-all-mode-lines+) (card16 (screen-position screen dpy))) (values ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (loop with bug-p = (and (= major 0) (< minor 8)) with offset of-type fixnum = 32 for i of-type card32 from 0 below (or (card32-get 8) 0) collect (let ((mode-info (make-mode-info :dotclock (card32-get offset) :hdisplay (card16-get (incf offset 4)) :hsyncstart (card16-get (incf offset 2)) :hsyncend (card16-get (incf offset 2)) :htotal (card16-get (incf offset 2)) :hskew (if (< major 2) 0 (card32-get (incf offset 2))) :vdisplay (card16-get (incf offset 4)) :vsyncstart (card16-get (incf offset 2)) :vsyncend (card16-get (incf offset 2)) :vtotal (card16-get (incf offset 2)) :flags (card32-get (incf offset (if (< major 2) 2 6))))) (size (card32-get (incf offset (if (< major 2) 4 16))))) (declare (type card32 size)) (incf offset 4) (when bug-p (setf size 0)) (setf (mode-info-privsize mode-info) size (mode-info-private mode-info) (sequence-get :format card32 :index offset :length size :result-type 'list)) (incf offset (* 4 size)) mode-info)))))) (defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info))) (declare (type display dpy) (type screen scr)) (let* ((private (mode-info-private new)) (privsize (mode-info-privsize new)) (major (xfree86-vidmode-query-version dpy)) (i (if (< major 2) 14 22)) (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0))) (declare (type card32 privsize) (type fixnum i) (type card16 major) (type simple-vector v)) (mode-info->v-card16 new major :encode-private nil :data v) (mode-info->v-card16 after major :encode-private nil :data v :index i) (setf i (- (* 2 i) 2)) ;; strore private info (sequence card32) according clx bytes order. (loop for card of-type card32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ card) (setf (svref v (incf i)) w1 (svref v (incf i)) w2))) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +add-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defun xfree86-vidmode-delete-mode-line (dpy scr mode-info) "Delete mode argument. The specified mode must match an existing mode. To be considered a match, all of the fields of the given mode-info structure must match, except the privsize and private fields. If the mode to be deleted is the current mode, a mode switch to the next mode will occur first. The last remaining mode can not be deleted." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +delete-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)))) (defconstant +mode-status+ '#(:MODE_BAD ; unspecified reason :MODE_ERROR ; error condition :MODE_OK ; Mode OK :MODE_HSYNC ; hsync out of range :MODE_VSYNC ; vsync out of range :MODE_H_ILLEGAL ; mode has illegal horizontal timings :MODE_V_ILLEGAL ; mode has illegal horizontal timings :MODE_BAD_WIDTH ; requires an unsupported linepitch :MODE_NO_MODE ; no mode with a maching name :MODE_NO_INTERLACE ; interlaced mode not supported :MODE_NO_DBLESCAN ; doublescan mode not supported :MODE_NO_VSCAN ; multiscan mode not supported :MODE_MEM ; insufficient video memory :MODE_VIRTUAL_X ; mode width too large for specified virtual size :MODE_VIRTUAL_Y ; mode height too large for specified virtual size :MODE_MEM_VIRT ; insufficient video memory given virtual size :MODE_NOCLOCK ; no fixed clock available :MODE_CLOCK_HIGH ; clock required is too high :MODE_CLOCK_LOW ; clock required is too low :MODE_CLOCK_RANGE ; clock/mode isn't in a ClockRange :MODE_BAD_HVALUE ; horizontal timing was out of range :MODE_BAD_VVALUE ; vertical timing was out of range :MODE_BAD_VSCAN ; VScan value out of range :MODE_HSYNC_NARROW ; horizontal sync too narrow :MODE_HSYNC_WIDE ; horizontal sync too wide :MODE_HBLANK_NARROW ; horizontal blanking too narrow :MODE_HBLANK_WIDE ; horizontal blanking too wide :MODE_VSYNC_NARROW ; vertical sync too narrow :MODE_VSYNC_WIDE ; vertical sync too wide :MODE_VBLANK_NARROW ; vertical blanking too narrow :MODE_VBLANK_WIDE ; vertical blanking too wide :MODE_PANEL ; exceeds panel dimensions :MODE_INTERLACE_WIDTH ; width too large for interlaced mode :MODE_ONE_WIDTH ; only one width is supported :MODE_ONE_HEIGHT ; only one height is supported :MODE_ONE_SIZE ; only one resolution is supported )) (defun decode-status-mode (status) (declare (type int32 status)) (svref +mode-status+ (+ status 2))) (defun xfree86-vidmode-validate-mode-line (dpy scr mode-info) "Checked the validity of a mode-info argument. If the specified mode can be used by the server (i.e. meets all the constraints placed upon a mode by the combination of the server, card, and monitor) the function returns :mode_ok otherwise it returns a keyword indicating the reason why the mode is invalid." (declare (type display dpy) (type screen scr)) (let* ((major (xfree86-vidmode-query-version dpy)) (v (mode-info->v-card16 mode-info major))) (declare (type card16 major) (type simple-vector v)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +validate-mode-line+) (card32 (screen-position scr dpy)) ((sequence :format card16) v)) (let ((status (integer-get 8))) (declare (type int32 status)) (when status (decode-status-mode status)))))) (defun xfree86-vidmode-get-gamma (display screen) (declare (type display display) (type screen screen)) (with-buffer-request-and-reply (display (vidmode-opcode display) nil :sizes (8 16 32)) ((data +get-gamma+) (card16 (screen-position screen display)) (card16 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0) (card32 0)) (values (/ (the card32 (or (card32-get 8) 0)) 10000.0) (/ (the card32 (or (card32-get 12) 0)) 10000.0) (/ (the card32 (or (card32-get 16) 0)) 10000.0)))) (defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0)) (declare (type display dpy) (type screen scr) (type (single-float 0.100f0 10.000f0) red green blue)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma+) (card16 (screen-position scr dpy)) (card16 0) (card32 (truncate (* red 10000))) (card32 (truncate (* green 10000))) (card32 (truncate (* blue 10000))) (card32 0) (card32 0) (card32 0))) (defun xfree86-vidmode-get-gamma-ramp (dpy scr size) (declare (type display dpy) (type screen scr) (type card16 size)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size)) (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2))) (declare (type fixnum rep-size)) (unless (zerop rep-size) (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2)))) (off2 (+ off1 rep-size (* 2 (mod rep-size 2))))) (declare (type fixnum off1 off2)) (values (sequence-get :format card16 :length (card16-get 8) :index 32 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off1 :result-type 'list) (sequence-get :format card16 :length (card16-get 8) :index off2 :result-type 'list))))))) (defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue) (declare (type (or null simple-vector) red green blue) (type card16 size) (type display dpy) (type screen scr)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-gamma-ramp+) (card16 (screen-position scr dpy)) (card16 size) ((sequence :format card16) (if (zerop (mod size 2)) (concatenate 'vector red green blue) (concatenate 'vector red '#(0) green '#(0) blue '#(0)))))) (defun xfree86-vidmode-get-gamma-ramp-size (dpy screen) (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-gamma-ramp-size+) (card16 (screen-position screen dpy)) (card16 0)) (card16-get 8))) (defun xfree86-vidmode-lock-mode-switch (display screen lock-p) "Allow or disallow mode switching whether the request to switch modes comes from a call to the mode switching functions or from one of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)." (declare (type display display) (type screen screen) (type boolean lock-p)) (with-buffer-request (display (vidmode-opcode display)) (data +lock-mode-switch+) (card16 (screen-position screen display)) (card16 (if lock-p 1 0)))) (defun xfree86-vidmode-switch-to-mode (display screen mode-info) "Switch directly to the specified mode. The specified mode must match an existing mode. Matching is as specified in the description of the xf86-vidmode-delete-mode-line function." (declare (type display display) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version display) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (the .private field wasn't being passed over the wire). ;; Check the server's version, and accept the old format if appropriate. (let ((bug-p (and (= major 0) (< minor 8))) (privsize (mode-info-privsize mode-info))) (declare (type boolean bug-p)) (and bug-p (setf (mode-info-privsize mode-info) 0)) (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p))) (declare (type simple-vector v)) (and bug-p (setf (mode-info-privsize mode-info) privsize)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-to-mode+) (card32 (screen-position screen display)) ((sequence :format card16) v)))))) (defun xfree86-vidmode-switch-mode (display screen zoom) "Change the video mode to next (or previous) video mode, depending of zoom sign. If positive, switch to next mode, else switch to prev mode." (declare (type display display) (type screen screen) (type card16 zoom)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 zoom))) (defun xfree86-vidmode-select-next-mode (display screen) "Change the video mode to next video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 1))) (defun xfree86-vidmode-select-prev-mode (display screen) "Change the video mode to previous video mode" (declare (type display display) (type screen screen)) (with-buffer-request (display (vidmode-opcode display)) (data +switch-mode+) (card16 (screen-position screen display)) (card16 #xFFFF))) (defun xfree86-vidmode-get-monitor (dpy screen) "Information known to the server about the monitor is returned. Multiple value return: hsync (list of hi, low, ...) vsync (list of hi, low, ...) vendor name model name The hi and low values will be equal if a discreate value was given in the XF86Config file." (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-monitor+) (card16 (screen-position screen dpy)) (card16 0)) (let* ((vendor-name-length (card8-get 8)) (model-name-length (card8-get 9)) (pad (- 4 (mod vendor-name-length 4))) (nhsync (card8-get 10)) (nvsync (card8-get 11)) (vindex (+ 32 (* 4 (+ nhsync nvsync)))) (mindex (+ vindex vendor-name-length pad)) (hsync (sequence-get :length nhsync :index 32 :result-type 'list)) (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4)) :result-type 'list))) (declare (type card8 nhsync nvsync vendor-name-length model-name-length) (type fixnum pad vindex mindex)) (values (loop for i of-type card32 in hsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (loop for i of-type card32 in vsync collect (/ (ldb (byte 16 0) i) 100.) collect (/ (ldb (byte 32 16) i) 100.)) (string-get vendor-name-length vindex) (string-get model-name-length mindex))))) (defun xfree86-vidmode-get-viewport (dpy screen) "Query the location of the upper left corner of the viewport into the virtual screen. The upper left coordinates will be returned as a multiple value." (declare (type display dpy) (type screen screen)) (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy) (declare (type card16 major minor)) ;; Note: There was a bug in the protocol implementation in versions ;; 0.x with x < 8 (no reply was sent, so the client would hang) ;; Check the server's version, and don't wait for a reply with older ;; versions. (when (and (= major 0) (< minor 8)) (format cl:*error-output* "running an old version ~a ~a~%" major minor) (return-from xfree86-vidmode-get-viewport nil)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-viewport+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) (card32-get 12))))) (defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0)) "Set upper left corner of the viewport into the virtual screen to the x and y keyword parameters value (zero will be theire default value)." (declare (type display dpy) (type screen screen) (type card32 x y)) (with-buffer-request (dpy (vidmode-opcode dpy)) (data +set-viewport+) (card16 (screen-position screen dpy)) (card16 0) (card32 x) (card32 y))) (defun xfree86-vidmode-get-dotclocks (dpy screen) "Returns as a multiple value return the server dotclock informations: flags maxclocks clock list" (declare (type display dpy) (type screen screen)) (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32)) ((data +get-dot-clocks+) (card16 (screen-position screen dpy)) (card16 0)) (values (card32-get 8) ; flags (card32-get 16) ; max clocks (sequence-get :length (card32-get 12) :format card32 :index 32 :result-type 'list)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; private utility routines ;;;; ;;;; ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun mode-info->v-card16 (mode-info major &key (encode-private t) (index 0) data) (declare (type integer index) (type card16 major) (type boolean encode-private) (type (or null simple-vector) data)) (let ((dotclock (mode-info-dotclock mode-info)) (hdisplay (mode-info-hdisplay mode-info)) (hsyncstart (mode-info-hsyncstart mode-info)) (hsyncend (mode-info-hsyncend mode-info)) (htotal (mode-info-htotal mode-info)) (hskew (mode-info-hskew mode-info)) (vdisplay (mode-info-vdisplay mode-info)) (vsyncstart (mode-info-vsyncstart mode-info)) (vsyncend (mode-info-vsyncend mode-info)) (vtotal (mode-info-vtotal mode-info)) (flags (mode-info-flags mode-info)) (privsize (mode-info-privsize mode-info)) (private (mode-info-private mode-info))) (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew) (type card16 vdisplay vsyncstart vsyncend vtotal) (type card32 dotclock flags privsize) (type (or null sequence) private)) (let* ((size (+ (if (< major 2) 14 22) (* privsize 2))) (v (or data (make-array size :initial-element 0)))) (declare (type fixnum size) (type simple-vector v)) ;; store dotclock (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ dotclock) (setf (svref v index) w1 (svref v (incf index)) w2)) (setf (svref v (incf index)) hdisplay (svref v (incf index)) hsyncstart (svref v (incf index)) hsyncend (svref v (incf index)) htotal) (unless (< major 2) (setf (svref v (incf index)) hskew)) (setf (svref v (incf index)) vdisplay (svref v (incf index)) vsyncstart (svref v (incf index)) vsyncend (svref v (incf index)) vtotal) (unless (< major 2) (incf index)) ;; strore flags (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ flags) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; strore privsize (card32) according clx bytes order. (multiple-value-bind (w1 w2) (__card32->card16__ privsize) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)) ;; reserverd byte32 1 2 3 (unless (< major 2) (incf index 6)) ;; strore private info (sequence card32) according clx bytes order. (when encode-private (loop for i of-type int32 in private do (multiple-value-bind (w1 w2) (__card32->card16__ i) (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) (declaim (inline __card32->card16__)) (defun __card32->card16__ (i) (declare (type card32 i)) #+clx-little-endian (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) #-clx-little-endian (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) cmucl-21a/src/code/000077500000000000000000000000001260377556400142625ustar00rootroot00000000000000cmucl-21a/src/code/alien-callback.lisp000066400000000000000000000367471260377556400200160ustar00rootroot00000000000000;;; -*- Package: ALIEN -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/alien-callback.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. ;;; (in-package "ALIEN") (use-package "EXT") (use-package "SYSTEM") (intl:textdomain "cmucl") (export '(alien * array struct union enum function integer signed unsigned boolean values single-float double-float long-float system-area-pointer def-alien-type def-alien-variable sap-alien extern-alien with-alien slot deref addr cast alien-sap alien-size alien-funcall def-alien-routine make-alien free-alien null-alien def-callback callback callback-funcall)) (in-package "ALIEN-INTERNALS") (in-package "ALIEN") (import '(alien alien-value alien-value-type parse-alien-type unparse-alien-type alien-type-= alien-subtype-p alien-typep def-alien-type-class def-alien-type-translator def-alien-type-method invoke-alien-type-method alien-type alien-type-p alien-type-bits alien-type-alignment alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p alien-float-type alien-float-type-p alien-single-float-type alien-single-float-type-p alien-double-float-type alien-double-float-type-p alien-long-float-type alien-long-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type alien-array-type-dimensions alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr %heap-alien %set-heap-alien %heap-alien-addr heap-alien-info heap-alien-info-p heap-alien-info-type heap-alien-info-sap-form local-alien %set-local-alien %local-alien-addr local-alien-info local-alien-info-p local-alien-info-type local-alien-info-force-to-memory-p %local-alien-forced-to-memory-p make-local-alien dispose-local-alien note-local-alien-type %cast %sap-alien align-offset extract-alien-value deposit-alien-value naturalize deport compute-lisp-rep-type compute-alien-rep-type compute-extract-lambda compute-deposit-lambda compute-naturalize-lambda compute-deport-lambda) "ALIEN-INTERNALS") (export '(alien alien-value alien-value-type parse-alien-type unparse-alien-type alien-type-= alien-subtype-p alien-typep def-alien-type-class def-alien-type-translator def-alien-type-method invoke-alien-type-method alien-type alien-type-p alien-type-bits alien-type-alignment alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p alien-float-type alien-float-type-p alien-single-float-type alien-single-float-type-p alien-double-float-type alien-double-float-type-p alien-long-float-type alien-long-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type alien-array-type-dimensions alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr %heap-alien %set-heap-alien %heap-alien-addr heap-alien-info heap-alien-info-p heap-alien-info-type heap-alien-info-sap-form local-alien %set-local-alien %local-alien-addr local-alien-info local-alien-info-p local-alien-info-type local-alien-info-force-to-memory-p %local-alien-forced-to-memory-p make-local-alien dispose-local-alien note-local-alien-type %cast %sap-alien align-offset extract-alien-value deposit-alien-value naturalize deport compute-lisp-rep-type compute-alien-rep-type compute-extract-lambda compute-deposit-lambda compute-naturalize-lambda compute-deport-lambda) "ALIEN-INTERNALS") ;;;; Alien callback support ;;;; ;;;; This is basically the implementation posted by Helmut Eller, ;;;; posted to cmucl-imp on 04/13/2003. It has been modified to live ;;;; in the ALIEN package and to fit the same style as the ALIEN ;;;; package. ;;; This package provides a mechanism for defining callbacks: lisp ;;; functions which can be called from foreign code. The user ;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See ;;; the doc-strings for details.) ;;; ;;; Below are two examples. The first example defines a callback FOO ;;; and calls it with alien-funcall. The second illustrates the use ;;; of the libc qsort function. ;;; ;;; The implementation generates a piece machine code -- a ;;; "trampoline" -- for each callback function. A pointer to this ;;; trampoline can then be passed to foreign code. The trampoline is ;;; allocated with malloc and is not moved by the GC. ;;; ;;; When called, the trampoline passes a pointer to the arguments ;;; (essentially the stack pointer) together with an index to ;;; CALL-CALLBACK. CALL-CALLBACK uses the index to find the ;;; corresponding lisp function and calls this function with the ;;; argument pointer. The lisp function uses the pointer to copy the ;;; arguments from the stack to local variables. On return, the lisp ;;; function stores the result into the location given by the argument ;;; pointer, and the trampoline code copies the return value from ;;; there into the right return register. ;;; ;;; The address of CALL-CALLBACK is used in every trampoline and must ;;; not be moved by the gc. It is therefore necessary to either ;;; include this package into the image (core) or to purify before ;;; creating any trampolines (or to invent some other trick). ;;; ;;; Examples: #|| ;;; Example 1: (alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) (format t "~&foo: ~S, ~S~%" arg1 arg2) (+ arg1 arg2)) (alien:alien-funcall (alien:sap-alien (alien:callback foo) (function c-call:int c-call:int c-call:int)) 555 444444) ;;; Example 2: (alien:def-alien-routine qsort c-call:void (base (* t)) (nmemb c-call:int) (size c-call:int) (compar (* (function c-call:int (* t) (* t))))) (alien:def-callback my< (c-call:int (arg1 (* c-call:double)) (arg2 (* c-call:double))) (let ((a1 (alien:deref arg1)) (a2 (alien:deref arg2))) (cond ((= a1 a2) 0) ((< a1 a2) -1) (t +1)))) (let ((a (make-array 10 :element-type 'double-float :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)))) (print a) (qsort (sys:vector-sap a) (length a) (alien:alien-size c-call:double :bytes) (alien:callback my<)) (print a)) ||# (defstruct (callback (:constructor make-callback (trampoline lisp-fn function-type))) "A callback consists of a piece assembly code -- the trampoline -- and a lisp function. We store the function type (including return type and arg types), so we can detect incompatible redefinitions." (trampoline (required-argument) :type system-area-pointer) (lisp-fn (required-argument) :type (function (fixnum fixnum) (values))) (function-type (required-argument) :type alien::alien-function-type)) (declaim (type (vector callback) *callbacks*)) (defvar *callbacks* (make-array 10 :element-type 'callback :fill-pointer 0 :adjustable t) "Vector of all callbacks.") (defun call-callback (index sp-fixnum ret-addr) (declare (type fixnum index sp-fixnum ret-addr) (optimize speed)) (funcall (callback-lisp-fn (aref *callbacks* index)) sp-fixnum ret-addr)) (defun create-callback (lisp-fn fn-type) (let* ((index (fill-pointer *callbacks*)) (tramp (vm:make-callback-trampoline index fn-type)) (cb (make-callback tramp lisp-fn fn-type))) (vector-push-extend cb *callbacks*) cb)) (defun address-of-call-callback () (kernel:get-lisp-obj-address #'call-callback)) (defun address-of-funcall3 () (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t)))))) ;;; Some abbreviations for alien-type classes. The $ suffix is there ;;; to prevent name clashes. (deftype void$ () '(satisfies alien-void-type-p)) (deftype integer$ () 'alien-integer-type) (deftype integer-64$ () '(satisfies alien-integer-64-type-p)) (deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) (deftype pointer$ () 'alien-pointer-type) (deftype single$ () 'alien-single-float-type) (deftype double$ () 'alien-double-float-type) (deftype sap$ () '(satisfies alien-sap-type=)) (defun alien-sap-type= (type) (alien-type-= type (parse-alien-type 'system-area-pointer))) (defun alien-void-type-p (type) (and (alien-values-type-p type) (null (alien-values-type-values type)))) (defun alien-integer-64-type-p (type) (and (alien-integer-type-p type) (= (alien-type-bits type) 64))) (defun alien-signed-integer-type-p (type) (and (alien-integer-type-p type) (alien-integer-type-signed type))) (defun segment-to-trampoline (segment length) (let* ((code (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) length)) (fill-pointer code)) ;; Make sure the malloc'ed area is executable. (let* ((page-size (get-page-size)) ;; mprotect wants address on a page boundary, so round down ;; the address and round up the length (code-base (sys:int-sap (* page-size (floor (sys:sap-int code) page-size)))) (len (* page-size (ceiling length page-size)))) (unless (unix::unix-mprotect code-base len (logior unix:prot_exec unix:prot_read unix:prot_write)) (warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work.") len length code-base code))) (new-assem:segment-map-output segment (lambda (sap length) (kernel:system-area-copy sap 0 fill-pointer 0 (* length vm:byte-bits)) (setf fill-pointer (sys:sap+ fill-pointer length)))) code)) (defun symbol-trampoline (symbol) (callback-trampoline (symbol-value symbol))) (defmacro callback (name) "Return the trampoline pointer for the callback NAME." `(symbol-trampoline ',name)) ;; Convenience macro to make it easy to call callbacks. (defmacro callback-funcall (name &rest args) `(alien-funcall (sap-alien (callback ,name) ,(unparse-alien-type (callback-function-type (symbol-value name)))) ,@args)) (defun define-callback-function (name lisp-fn fn-type) (declare (type symbol name) (type function lisp-fn)) (flet ((register-new-callback () (setf (symbol-value name) (create-callback lisp-fn fn-type)))) (if (and (boundp name) (callback-p (symbol-value name))) ;; try do redefine the existing callback (let ((callback (find (symbol-trampoline name) *callbacks* :key #'callback-trampoline :test #'sys:sap=))) (cond (callback (let ((old-type (callback-function-type callback))) (cond ((vm::compatible-function-types-p old-type fn-type) ;; (format t "~&; Redefining callback ~A~%" name) (setf (callback-lisp-fn callback) lisp-fn) (setf (callback-function-type callback) fn-type) callback) (t (let ((e (format nil (intl:gettext "~ Attempt to redefine callback with incompatible return type. Old type was: ~A New type is: ~A") old-type fn-type)) (c (format nil (intl:gettext "~ Create new trampoline (old trampoline calls old lisp function).")))) (cerror c e) (register-new-callback)))))) (t (register-new-callback)))) (register-new-callback)))) (defun word-aligned-bits (type) (align-offset (alien-type-bits type) vm:word-bits)) (defun argument-size (spec) (let ((type (parse-alien-type spec))) (typecase type ((or integer$ single$ double$ pointer$ sap$) (ceiling (word-aligned-bits type) vm:byte-bits)) (t (error (intl:gettext "Unsupported argument type: ~A") spec))))) (defun parse-return-type (spec) (let ((*values-type-okay* t)) (parse-alien-type spec))) (defun parse-function-type (return-type arg-specs) (parse-alien-type `(function ,return-type ,@(mapcar #'second arg-specs)))) (defun return-exp (spec sap body) (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body))) (let ((type (parse-return-type spec))) (typecase type (void$ body) (signed-integer$ (store `(signed ,(word-aligned-bits type)))) (integer$ (store `(unsigned ,(word-aligned-bits type)))) ((or single$ double$ pointer$ sap$) (store spec)) (t (error (intl:gettext "Unsupported return type: ~A") spec)))))) (defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc)) "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) {doc-string} {decls}* {FORM}*) Define a function which can be called by foreign code. The pointer returned by (callback NAME), when called by foreign code, invokes the lisp function. The lisp function expects alien arguments of the specified ARG-TYPEs and returns an alien of type RETURN-TYPE. If (callback NAME) is already a callback function pointer, its value is not changed (though it's arranged that an updated version of the lisp callback function will be called). This feature allows for incremental redefinition of callback functions." (let ((sp-fixnum (gensym (string :sp-fixnum-))) (ret-addr (gensym (string :ret-addr-))) (sp (gensym (string :sp-))) (ret (gensym (string :ret-)))) `(progn (defun ,name (,sp-fixnum ,ret-addr) ,@(when doc (list doc)) (declare (type fixnum ,sp-fixnum ,ret-addr)) ,@decls ;; We assume sp-fixnum is word aligned and pass it untagged to ;; this function. The shift compensates this. (let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum) 2))) (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr) 2)))) (declare (ignorable ,sp ,ret)) ;; Copy all arguments to local variables. (with-alien ,(loop for offset = 0 then (+ offset (argument-size type)) for (name type) in arg-specs collect `(,name ,type :local ,(vm:callback-accessor-form type sp offset))) ,(return-exp return-type ret `(progn ,@body)) (values)))) (define-callback-function ',name #',name ',(parse-function-type return-type arg-specs))))) ;;; dumping support (defun restore-callbacks () ;; Create new trampolines on reload. (loop for cb across *callbacks* for i from 0 do (setf (callback-trampoline cb) (vm:make-callback-trampoline i (callback-function-type cb))))) ;; *after-save-initializations* contains ;; new-assem::forget-output-blocks, and the assembler may not work ;; before forget-output-blocks was called. We add 'restore-callback at ;; the end of *after-save-initializations* to sidestep this problem. (setf *after-save-initializations* (append *after-save-initializations* (list 'restore-callbacks))) ;;; callback.lisp ends here cmucl-21a/src/code/alieneval.lisp000066400000000000000000002063751260377556400171300ustar00rootroot00000000000000;;; -*- Package: ALIEN -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/alieneval.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. ;;; (in-package "ALIEN") (use-package "EXT") (use-package "SYSTEM") (intl:textdomain "cmucl") (export '(alien * array struct union enum function integer signed unsigned boolean values single-float double-float long-float system-area-pointer def-alien-type def-alien-variable sap-alien extern-alien with-alien slot deref addr cast alien-sap alien-size alien-funcall def-alien-routine make-alien free-alien null-alien def-callback callback callback-funcall)) (in-package "ALIEN-INTERNALS") (in-package "ALIEN") (import '(alien alien-value alien-value-type parse-alien-type unparse-alien-type alien-type-= alien-subtype-p alien-typep def-alien-type-class def-alien-type-translator def-alien-type-method invoke-alien-type-method alien-type alien-type-p alien-type-bits alien-type-alignment alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p alien-float-type alien-float-type-p alien-single-float-type alien-single-float-type-p alien-double-float-type alien-double-float-type-p alien-long-float-type alien-long-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type alien-array-type-dimensions alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr %heap-alien %set-heap-alien %heap-alien-addr heap-alien-info heap-alien-info-p heap-alien-info-type heap-alien-info-sap-form local-alien %set-local-alien %local-alien-addr local-alien-info local-alien-info-p local-alien-info-type local-alien-info-force-to-memory-p %local-alien-forced-to-memory-p make-local-alien dispose-local-alien note-local-alien-type %cast %sap-alien align-offset extract-alien-value deposit-alien-value naturalize deport compute-lisp-rep-type compute-alien-rep-type compute-extract-lambda compute-deposit-lambda compute-naturalize-lambda compute-deport-lambda) "ALIEN-INTERNALS") (export '(alien alien-value alien-value-type parse-alien-type unparse-alien-type alien-type-= alien-subtype-p alien-typep def-alien-type-class def-alien-type-translator def-alien-type-method invoke-alien-type-method alien-type alien-type-p alien-type-bits alien-type-alignment alien-integer-type alien-integer-type-p alien-integer-type-signed alien-boolean-type alien-boolean-type-p alien-enum-type alien-enum-type-p alien-float-type alien-float-type-p alien-single-float-type alien-single-float-type-p alien-double-float-type alien-double-float-type-p alien-long-float-type alien-long-float-type-p alien-pointer-type alien-pointer-type-p alien-pointer-type-to make-alien-pointer-type alien-array-type alien-array-type-p alien-array-type-element-type alien-array-type-dimensions alien-record-type alien-record-type-p alien-record-type-fields alien-record-field alien-record-field-p alien-record-field-name alien-record-field-type alien-record-field-offset alien-function-type alien-function-type-p make-alien-function-type alien-function-type-result-type alien-function-type-arg-types alien-values-type alien-values-type-p alien-values-type-values *values-type-okay* %set-slot %slot-addr %set-deref %deref-addr %heap-alien %set-heap-alien %heap-alien-addr heap-alien-info heap-alien-info-p heap-alien-info-type heap-alien-info-sap-form local-alien %set-local-alien %local-alien-addr local-alien-info local-alien-info-p local-alien-info-type local-alien-info-force-to-memory-p %local-alien-forced-to-memory-p make-local-alien dispose-local-alien note-local-alien-type %cast %sap-alien align-offset extract-alien-value deposit-alien-value naturalize deport compute-lisp-rep-type compute-alien-rep-type compute-extract-lambda compute-deposit-lambda compute-naturalize-lambda compute-deport-lambda) "ALIEN-INTERNALS") ;;;; Utility functions. (defun align-offset (offset alignment) (let ((extra (rem offset alignment))) (if (zerop extra) offset (+ offset (- alignment extra))))) ;; This guesses the alignment of some object, using the natural ;; alignment. (defun guess-alignment (bits) (cond ((null bits) nil) #-x86 ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) (t 1))) ;; This is mostly for ppc. The first object in a structure gets the ;; natural alignment, but all subsequent objects get an alignment of ;; at most 4 bytes (32 bits). ;; ;; For more details, see the Power alignment mode in ;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html ;; for details. ;; (defun embedded-alignment (bits &optional firstp) (let ((align (guess-alignment bits))) (if firstp align (min align #+(and ppc darwin) 32 #-(and ppc darwin) 64)))) ;;;; Alien-type-info stuff. (eval-when (compile eval load) (defstruct (alien-type-class (:print-function %print-alien-type-class)) (name nil :type symbol) (include nil :type (or null alien-type-class)) (unparse nil :type (or null function)) (type= nil :type (or null function)) (lisp-rep nil :type (or null function)) (alien-rep nil :type (or null function)) (extract-gen nil :type (or null function)) (deposit-gen nil :type (or null function)) (naturalize-gen nil :type (or null function)) (deport-gen nil :type (or null function)) ;; Cast? (arg-tn nil :type (or null function)) (result-tn nil :type (or null function)) (subtypep nil :type (or null function))) (defun %print-alien-type-class (type-class stream depth) (declare (ignore depth)) (print-unreadable-object (type-class stream :type t) (prin1 (alien-type-class-name type-class) stream))) (defvar *alien-type-classes* (make-hash-table :test #'eq)) (defun alien-type-class-or-lose (name) (or (gethash name *alien-type-classes*) (error (intl:gettext "No alien type class ~S") name))) (defun create-alien-type-class-if-necessary (name include) (let ((old (gethash name *alien-type-classes*)) (include (and include (alien-type-class-or-lose include)))) (if old (setf (alien-type-class-include old) include) (setf (gethash name *alien-type-classes*) (make-alien-type-class :name name :include include))))) (defconstant method-slot-alist '((:unparse . alien-type-class-unparse) (:type= . alien-type-class-type=) (:subtypep . alien-type-class-subtypep) (:lisp-rep . alien-type-class-lisp-rep) (:alien-rep . alien-type-class-alien-rep) (:extract-gen . alien-type-class-extract-gen) (:deposit-gen . alien-type-class-deposit-gen) (:naturalize-gen . alien-type-class-naturalize-gen) (:deport-gen . alien-type-class-deport-gen) ;; Cast? (:arg-tn . alien-type-class-arg-tn) (:result-tn . alien-type-class-result-tn))) (defun method-slot (method) (cdr (or (assoc method method-slot-alist) (error (intl:gettext "No method ~S") method)))) ); eval-when ;;; We define a keyword "BOA" constructor so that we can reference the slots ;;; names in init forms. ;;; (defmacro def-alien-type-class ((name &key include include-args) &rest slots) (let ((defstruct-name (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE")))) (multiple-value-bind (include include-defstruct overrides) (etypecase include (null (values nil 'alien-type nil)) (symbol (values include (intern (concatenate 'string "ALIEN-" (symbol-name include) "-TYPE")) nil)) (list (values (car include) (intern (concatenate 'string "ALIEN-" (symbol-name (car include)) "-TYPE")) (cdr include)))) `(progn (eval-when (compile load eval) (create-alien-type-class-if-necessary ',name ',(or include 'root))) (defstruct (,defstruct-name (:include ,include-defstruct (:class ',name) ,@overrides) (:constructor ,(intern (concatenate 'string "MAKE-" (string defstruct-name))) (&key class bits alignment ,@(mapcar #'(lambda (x) (if (atom x) x (car x))) slots) ,@include-args))) ,@slots))))) (defmacro def-alien-type-method ((class method) lambda-list &rest body) (let ((defun-name (intern (concatenate 'string (symbol-name class) "-" (symbol-name method) "-METHOD")))) `(progn (defun ,defun-name ,lambda-list ,@body) (setf (,(method-slot method) (alien-type-class-or-lose ',class)) #',defun-name)))) (defmacro invoke-alien-type-method (method type &rest args) (let ((slot (method-slot method))) (once-only ((type type)) `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type)) (alien-type-class-include class))) ((null class) (error (intl:gettext "Method ~S not defined for ~S") ',method (alien-type-class ,type))) (let ((fn (,slot class))) (when fn (return fn)))) ,type ,@args)))) ;;;; Alien-type defstruct. (eval-when (compile load eval) (create-alien-type-class-if-necessary 'root nil)) (defstruct (alien-type (:print-function %print-alien-type) (:make-load-form-fun :just-dump-it-normally) (:constructor make-alien-type (&key class bits alignment))) (class 'root :type symbol) (bits nil :type (or null unsigned-byte)) (alignment (guess-alignment bits) :type (or null unsigned-byte))) (defun %print-alien-type (type stream depth) (declare (ignore depth)) (print-unreadable-object (type stream :type t) (prin1 (unparse-alien-type type) stream))) ;;;; Type parsing and unparsing. (defvar *auxiliary-type-definitions* nil) (defvar *new-auxiliary-types*) ;;; WITH-AUXILIARY-ALIEN-TYPES -- internal. ;;; ;;; Process stuff in a new scope. ;;; (defmacro with-auxiliary-alien-types (&body body) `(let ((*auxiliary-type-definitions* (if (boundp '*new-auxiliary-types*) (append *new-auxiliary-types* *auxiliary-type-definitions*) *auxiliary-type-definitions*)) (*new-auxiliary-types* nil)) ,@body)) ;;; PARSE-ALIEN-TYPE -- public ;;; (defun parse-alien-type (type) "Parse the list structure TYPE as an alien type specifier and return the resultant alien-type structure." (if (boundp '*new-auxiliary-types*) (%parse-alien-type type) (let ((*new-auxiliary-types* nil)) (%parse-alien-type type)))) (defun %parse-alien-type (type) (if (consp type) (let ((translator (info alien-type translator (car type)))) (unless translator (error (intl:gettext "Unknown alien type: ~S") type)) (funcall translator type)) (case (info alien-type kind type) (:primitive (let ((translator (info alien-type translator type))) (unless translator (error (intl:gettext "No translator for primitive alien type ~S?") type)) (funcall translator (list type)))) (:defined (or (info alien-type definition type) (error (intl:gettext "Definition missing for alien type ~S?") type))) (:unknown (error (intl:gettext "Unknown alien type: ~S") type))))) (defun auxiliary-alien-type (kind name) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (let ((in-auxiliaries (or (find-if #'aux-defn-matches *new-auxiliary-types*) (find-if #'aux-defn-matches *auxiliary-type-definitions*)))) (if in-auxiliaries (values (third in-auxiliaries) t) (ecase kind (:struct (info alien-type struct name)) (:union (info alien-type union name)) (:enum (info alien-type enum name))))))) (defun %set-auxiliary-alien-type (kind name defn) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (when (find-if #'aux-defn-matches *new-auxiliary-types*) (error (intl:gettext "Attempt to multiple define ~A ~S.") kind name)) (when (find-if #'aux-defn-matches *auxiliary-type-definitions*) (error (intl:gettext "Attempt to shadow definition of ~A ~S.") kind name))) (push (list kind name defn) *new-auxiliary-types*) defn) (defsetf auxiliary-alien-type %set-auxiliary-alien-type) (defun verify-local-auxiliaries-okay () (dolist (info *new-auxiliary-types*) (destructuring-bind (kind name defn) info (declare (ignore defn)) (when (ecase kind (:struct (info alien-type struct name)) (:union (info alien-type union name)) (:enum (info alien-type enum name))) (error (intl:gettext "Attempt to shadow definition of ~A ~S.") kind name))))) ;;; *record-type-already-unparsed* -- internal ;;; ;;; Holds the list of record types that have already been unparsed. This is ;;; used to keep from outputting the slots again if the same structure shows ;;; up twice. ;;; (defvar *record-types-already-unparsed*) ;;; UNPARSE-ALIEN-TYPE -- public. ;;; (defun unparse-alien-type (type) "Convert the alien-type structure TYPE back into a list specification of the type." (declare (type alien-type type)) (let ((*record-types-already-unparsed* nil)) (%unparse-alien-type type))) ;;; %UNPARSE-ALIEN-TYPE -- internal. ;;; ;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we need ;;; to recurse inside the binding of *record-types-already-unparsed*. ;;; (defun %unparse-alien-type (type) (invoke-alien-type-method :unparse type)) ;;;; Alien type defining stuff. (defmacro def-alien-type-translator (name lambda-list &body body) (let ((whole (gensym)) (defun-name (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE-TRANSLATOR")))) (multiple-value-bind (body decls docs) (lisp::parse-defmacro lambda-list whole body name 'def-alien-type-translator) `(progn (defun ,defun-name (,whole) ,decls (block ,name ,body)) (%def-alien-type-translator ',name #',defun-name ,docs))))) (defun %def-alien-type-translator (name translator docs) (declare (ignore docs)) (setf (info alien-type kind name) :primitive) (setf (info alien-type translator name) translator) (clear-info alien-type definition name) #+nil (setf (documentation name 'alien-type) docs) name) (defmacro def-alien-type (name type) "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for STRUCT and UNION types, in which case the name is taken from the type specifier." (with-auxiliary-alien-types (let ((alien-type (parse-alien-type type))) `(eval-when (compile load eval) ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) ,@(when name `((%def-alien-type ',name ',alien-type))))))) (defun %def-auxiliary-alien-types (types) (dolist (info types) (destructuring-bind (kind name defn) info (macrolet ((frob (kind) `(let ((old (info alien-type ,kind name))) (unless (or (null old) (alien-type-= old defn)) (warn (intl:gettext "Redefining ~A ~S to be:~% ~S,~%was:~% ~S") kind name defn old)) (setf (info alien-type ,kind name) defn)))) (ecase kind (:struct (frob struct)) (:union (frob union)) (:enum (frob enum))))))) (defun %def-alien-type (name new) (ecase (info alien-type kind name) (:primitive (error (intl:gettext "~S is a built-in alien type.") name)) (:defined (let ((old (info alien-type definition name))) (unless (or (null old) (alien-type-= new old)) (warn (intl:gettext "Redefining ~S to be:~% ~S,~%was~% ~S") name (unparse-alien-type new) (unparse-alien-type old))))) (:unknown)) (setf (info alien-type definition name) new) (setf (info alien-type kind name) :defined) name) ;;;; Interfaces to the different methods (defun alien-type-= (type1 type2) "Return T iff TYPE1 and TYPE2 describe equivalent alien types." (or (eq type1 type2) (and (eq (alien-type-class type1) (alien-type-class type2)) (invoke-alien-type-method :type= type1 type2)))) (defun alien-subtype-p (type1 type2) "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the only supported subtype relationships are that any pointer type is a subtype of (* t), and any array type's first dimension will match (array nil ...). Otherwise, the two types have to be ALIEN-TYPE-=." (or (eq type1 type2) (invoke-alien-type-method :subtypep type1 type2))) (defun alien-typep (object type) "Return T iff OBJECT is an alien of type TYPE." (let ((lisp-rep-type (compute-lisp-rep-type type))) (if lisp-rep-type (typep object lisp-rep-type) (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) (defun compute-naturalize-lambda (type) `(lambda (alien ignore) (declare (ignore ignore)) ,(invoke-alien-type-method :naturalize-gen type 'alien))) (defun compute-deport-lambda (type) (declare (type alien-type type)) (multiple-value-bind (form value-type) (invoke-alien-type-method :deport-gen type 'value) `(lambda (value ignore) (declare (type ,(or value-type (compute-lisp-rep-type type) `(alien ,type)) value) (ignore ignore)) ,form))) (defun compute-extract-lambda (type) `(lambda (sap offset ignore) (declare (type system-area-pointer sap) (type unsigned-byte offset) (ignore ignore)) (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset) ',type))) (defun compute-deposit-lambda (type) (declare (type alien-type type)) `(lambda (sap offset ignore value) (declare (type system-area-pointer sap) (type unsigned-byte offset) (ignore ignore)) (let ((value (deport value ',type))) ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) ;; Note: the reason we don't just return the pre-deported value ;; is because that would inhibit any (deport (naturalize ...)) ;; optimizations that might have otherwise happen. Re-naturalizing ;; the value might cause extra consing, but is flushable, so probably ;; results in better code. (naturalize value ',type)))) (defun compute-lisp-rep-type (type) (invoke-alien-type-method :lisp-rep type)) (defun compute-alien-rep-type (type) (invoke-alien-type-method :alien-rep type)) ;;;; Default methods. (def-alien-type-method (root :unparse) (type) `(!!unknown-alien-type!! ,(type-of type))) (def-alien-type-method (root :type=) (type1 type2) (declare (ignore type1 type2)) t) (def-alien-type-method (root :subtypep) (type1 type2) (alien-type-= type1 type2)) (def-alien-type-method (root :lisp-rep) (type) (declare (ignore type)) nil) (def-alien-type-method (root :alien-rep) (type) (declare (ignore type)) '*) (def-alien-type-method (root :naturalize-gen) (type alien) (declare (ignore alien)) (error (intl:gettext "Cannot represent ~S typed aliens.") type)) (def-alien-type-method (root :deport-gen) (type object) (declare (ignore object)) (error (intl:gettext "Cannot represent ~S typed aliens.") type)) (def-alien-type-method (root :extract-gen) (type sap offset) (declare (ignore sap offset)) (error (intl:gettext "Cannot represent ~S typed aliens.") type)) (def-alien-type-method (root :deposit-gen) (type sap offset value) `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) (def-alien-type-method (root :arg-tn) (type state) (declare (ignore state)) (error (intl:gettext "Cannot pass aliens of type ~S as arguments to call-out") (unparse-alien-type type))) (def-alien-type-method (root :result-tn) (type state) (declare (ignore state)) (error (intl:gettext "Cannot return aliens of type ~S from call-out") (unparse-alien-type type))) ;;;; The INTEGER type. (def-alien-type-class (integer) (signed t :type (member t nil))) (def-alien-type-translator signed (&optional (bits vm:word-bits)) (make-alien-integer-type :bits bits)) (def-alien-type-translator integer (&optional (bits vm:word-bits)) (make-alien-integer-type :bits bits)) (def-alien-type-translator unsigned (&optional (bits vm:word-bits)) (make-alien-integer-type :bits bits :signed nil)) (def-alien-type-method (integer :unparse) (type) (list (if (alien-integer-type-signed type) 'signed 'unsigned) (alien-integer-type-bits type))) (def-alien-type-method (integer :type=) (type1 type2) (and (eq (alien-integer-type-signed type1) (alien-integer-type-signed type2)) (= (alien-integer-type-bits type1) (alien-integer-type-bits type2)))) (def-alien-type-method (integer :lisp-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) (def-alien-type-method (integer :alien-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) #-amd64 (def-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) alien) ;; signed numbers <= 32 bits need to be sign extended. ;; I really should use the movsxd instruction, but I don't ;; know how. #+amd64 (defun sign-extend-32-bit (num) (if (> num #x7fffffff) (- num #x100000000) num)) #+amd64 (def-alien-type-method (integer :naturalize-gen) (type alien) (if (and (alien-integer-type-signed type) (< (alien-integer-type-bits type) 64)) `(sign-extend-32-bit ,alien) alien)) (def-alien-type-method (integer :deport-gen) (type value) (declare (ignore type)) value) (def-alien-type-method (integer :extract-gen) (type sap offset) (declare (type alien-integer-type type)) (let ((ref-fun (if (alien-integer-type-signed type) (case (alien-integer-type-bits type) (8 'signed-sap-ref-8) (16 'signed-sap-ref-16) (32 'signed-sap-ref-32) (64 'signed-sap-ref-64)) (case (alien-integer-type-bits type) (8 'sap-ref-8) (16 'sap-ref-16) (32 'sap-ref-32) (64 'sap-ref-64))))) (if ref-fun `(,ref-fun ,sap (/ ,offset vm:byte-bits)) (error (intl:gettext "Cannot extract ~D bit integers.") (alien-integer-type-bits type))))) ;;;; The BOOLEAN type. (def-alien-type-class (boolean :include integer :include-args (signed))) (def-alien-type-translator boolean (&optional (bits vm:word-bits)) (make-alien-boolean-type :bits bits :signed nil)) (def-alien-type-method (boolean :unparse) (type) `(boolean ,(alien-boolean-type-bits type))) (def-alien-type-method (boolean :lisp-rep) (type) (declare (ignore type)) `(member t nil)) (def-alien-type-method (boolean :naturalize-gen) (type alien) (declare (ignore type)) `(not (zerop ,alien))) (def-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type)) `(if ,value 1 0)) ;;;; The ENUM type. (def-alien-type-class (enum :include (integer (:bits 32)) :include-args (signed)) name ; name of this enum (if any) from ; alist from keywords to integers. to ; alist or vector from integers to keywords. kind ; Kind of from mapping, :vector or :alist. offset) ; Offset to add to value for :vector from mapping. (def-alien-type-translator enum (&whole type name &rest mappings) (cond (mappings (let ((result (parse-enum name mappings))) (when name (multiple-value-bind (old old-p) (auxiliary-alien-type :enum name) (when old-p (unless (alien-type-= result old) (warn (intl:gettext "Redefining alien enum ~S") name))) ;; I (rtoy) am not 100% sure about this. But compare ;; what this does with what PARSE-ALIEN-RECORD-TYPE ;; does. So, if we've seen this type before and it's ;; the same type, we don't need to setf ;; auxiliary-alien-type. This gets around the problem ;; noted by Nicolas Neuss on cmucl-help, 2004/11/09 ;; where he had something like ;; ;; (def-alien-type yes-no-t (enum yes-no-t :no :yes)) ;; (def-alien-type nil ;; (struct foo ;; (arg1 yes-no-t) ;; (arg2 yes-no-t))) (when (or (not old-p) (not (alien-type-= result old))) (setf (auxiliary-alien-type :enum name) result)))) result)) (name (multiple-value-bind (result found) (auxiliary-alien-type :enum name) (unless found (error (intl:gettext "Unknown enum type: ~S") name)) result)) (t (error (intl:gettext "Empty enum type: ~S") type)))) (defun parse-enum (name elements) (when (null elements) (error (intl:gettext "An enumeration must contain at least one element."))) (let ((min nil) (max nil) (from-alist ()) (prev -1)) (declare (list from-alist)) (dolist (el elements) (multiple-value-bind (sym val) (if (listp el) (values (first el) (second el)) (values el (1+ prev))) (setf prev val) (unless (keywordp sym) (error (intl:gettext "Enumeration element ~S is not a keyword.") sym)) (unless (integerp val) (error (intl:gettext "Element value ~S is not an integer.") val)) (unless (and max (> max val)) (setq max val)) (unless (and min (< min val)) (setq min val)) (when (rassoc val from-alist) (error (intl:gettext "Element value ~S used more than once.") val)) (when (assoc sym from-alist :test #'eq) (error (intl:gettext "Enumeration element ~S used more than once.") sym)) (push (cons sym val) from-alist))) (let* ((signed (minusp min)) (min-bits (if signed (1+ (max (integer-length min) (integer-length max))) (integer-length max)))) (when (> min-bits 32) (error (intl:gettext "Can't represent enums needing more than 32 bits."))) (setf from-alist (sort from-alist #'< :key #'cdr)) (cond ;; ;; If range is at least 20% dense, use vector mapping. Crossover ;; point solely on basis of space would be 25%. Vector mapping ;; is always faster, so give the benefit of the doubt. ((< 0.2 (/ (float (length from-alist)) (float (- max min)))) ;; ;; If offset is small and ignorable, ignore it to save time. (when (< 0 min 10) (setq min 0)) (let ((to (make-array (1+ (- max min))))) (dolist (el from-alist) (setf (svref to (- (cdr el) min)) (car el))) (make-alien-enum-type :name name :signed signed :from from-alist :to to :kind :vector :offset (- min)))) (t (make-alien-enum-type :name name :signed signed :from from-alist :to (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist) :kind :alist)))))) (def-alien-type-method (enum :unparse) (type) `(enum ,(alien-enum-type-name type) ,@(let ((prev -1)) (mapcar #'(lambda (mapping) (let ((sym (car mapping)) (value (cdr mapping))) (prog1 (if (= (1+ prev) value) sym `(,sym ,value)) (setf prev value)))) (alien-enum-type-from type))))) (def-alien-type-method (enum :type=) (type1 type2) (and (eq (alien-enum-type-name type1) (alien-enum-type-name type2)) (equal (alien-enum-type-from type1) (alien-enum-type-from type2)))) (def-alien-type-method (enum :lisp-rep) (type) `(member ,@(mapcar #'car (alien-enum-type-from type)))) (def-alien-type-method (enum :naturalize-gen) (type alien) (ecase (alien-enum-type-kind type) (:vector `(svref ',(alien-enum-type-to type) (+ ,alien ,(alien-enum-type-offset type)))) (:alist `(ecase ,alien ,@(mapcar #'(lambda (mapping) `(,(car mapping) ,(cdr mapping))) (alien-enum-type-to type)))))) (def-alien-type-method (enum :deport-gen) (type value) `(ecase ,value ,@(mapcar #'(lambda (mapping) `(,(car mapping) ,(cdr mapping))) (alien-enum-type-from type)))) ;;;; the FLOAT types. (def-alien-type-class (float) (type (required-argument) :type symbol)) (def-alien-type-method (float :unparse) (type) (alien-float-type-type type)) (def-alien-type-method (float :lisp-rep) (type) (alien-float-type-type type)) (def-alien-type-method (float :alien-rep) (type) (alien-float-type-type type)) (def-alien-type-method (float :naturalize-gen) (type alien) (declare (ignore type)) alien) (def-alien-type-method (float :deport-gen) (type value) (declare (ignore type)) value) (def-alien-type-class (single-float :include (float (:bits 32)) :include-args (type))) (def-alien-type-translator single-float () (make-alien-single-float-type :type 'single-float)) (def-alien-type-method (single-float :extract-gen) (type sap offset) (declare (ignore type)) `(sap-ref-single ,sap (/ ,offset vm:byte-bits))) (def-alien-type-class (double-float :include (float (:bits 64)) :include-args (type))) (def-alien-type-translator double-float () (make-alien-double-float-type :type 'double-float)) (def-alien-type-method (double-float :extract-gen) (type sap offset) (declare (ignore type)) `(sap-ref-double ,sap (/ ,offset vm:byte-bits))) #+long-float (def-alien-type-class (long-float :include (float (:bits #+x86 96 #+sparc 128)) :include-args (type))) #+long-float (def-alien-type-translator long-float () (make-alien-long-float-type :type 'long-float)) #+long-float (def-alien-type-method (long-float :extract-gen) (type sap offset) (declare (ignore type)) `(sap-ref-long ,sap (/ ,offset vm:byte-bits))) ;;;; The SAP type (def-alien-type-class (system-area-pointer)) (def-alien-type-translator system-area-pointer () (make-alien-system-area-pointer-type :bits #-alpha vm:word-bits #+alpha 64)) (def-alien-type-method (system-area-pointer :unparse) (type) (declare (ignore type)) 'system-area-pointer) (def-alien-type-method (system-area-pointer :lisp-rep) (type) (declare (ignore type)) 'system-area-pointer) (def-alien-type-method (system-area-pointer :alien-rep) (type) (declare (ignore type)) 'system-area-pointer) (def-alien-type-method (system-area-pointer :naturalize-gen) (type alien) (declare (ignore type)) alien) (def-alien-type-method (system-area-pointer :deport-gen) (type object) (declare (ignore type)) object) (def-alien-type-method (system-area-pointer :extract-gen) (type sap offset) (declare (ignore type)) `(sap-ref-sap ,sap (/ ,offset vm:byte-bits))) ;;;; the ALIEN-VALUE type. (def-alien-type-class (alien-value :include system-area-pointer)) (def-alien-type-method (alien-value :lisp-rep) (type) (declare (ignore type)) nil) (def-alien-type-method (alien-value :naturalize-gen) (type alien) `(%sap-alien ,alien ',type)) (def-alien-type-method (alien-value :deport-gen) (type value) (declare (ignore type)) `(alien-sap ,value)) ;;;; The POINTER type. (def-alien-type-class (pointer :include (alien-value (:bits #-alpha vm:word-bits #+alpha 64))) (to nil :type (or alien-type null))) (def-alien-type-translator * (to) (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to)))) (def-alien-type-method (pointer :unparse) (type) (let ((to (alien-pointer-type-to type))) `(* ,(if to (%unparse-alien-type to) t)))) (def-alien-type-method (pointer :type=) (type1 type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) (if to1 (if to2 (alien-type-= to1 to2) nil) (null to2)))) (def-alien-type-method (pointer :subtypep) (type1 type2) (and (alien-pointer-type-p type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) (if to1 (if to2 (alien-subtype-p to1 to2) t) (null to2))))) (def-alien-type-method (pointer :deport-gen) (type value) (values `(etypecase ,value (null (int-sap 0)) (system-area-pointer ,value) ((alien ,type) (alien-sap ,value))) `(or null system-area-pointer (alien ,type)))) ;;;; The MEM-BLOCK type. (def-alien-type-class (mem-block :include alien-value)) (def-alien-type-method (mem-block :extract-gen) (type sap offset) (declare (ignore type)) `(sap+ ,sap (/ ,offset vm:byte-bits))) (def-alien-type-method (mem-block :deposit-gen) (type sap offset value) (let ((bits (alien-mem-block-type-bits type))) (unless bits (error (intl:gettext "Cannot deposit aliens of type ~S (unknown size).") type)) `(kernel:system-area-copy ,value 0 ,sap ,offset ',bits))) ;;;; The ARRAY type. (def-alien-type-class (array :include mem-block) (element-type (required-argument) :type alien-type) (dimensions (required-argument) :type list)) (def-alien-type-translator array (ele-type &rest dims) (when dims (unless (typep (first dims) '(or kernel:index null)) (error (intl:gettext "First dimension is not a non-negative fixnum or NIL: ~S") (first dims))) (let ((loser (find-if-not #'(lambda (x) (typep x 'kernel:index)) (rest dims)))) (when loser (error (intl:gettext "Dimension is not a non-negative fixnum: ~S") loser)))) (let ((type (parse-alien-type ele-type))) (make-alien-array-type :element-type type :dimensions dims :alignment (alien-type-alignment type) :bits (if (and (alien-type-bits type) (every #'integerp dims)) (* (align-offset (alien-type-bits type) (alien-type-alignment type)) (reduce #'* dims)))))) (def-alien-type-method (array :unparse) (type) `(array ,(%unparse-alien-type (alien-array-type-element-type type)) ,@(alien-array-type-dimensions type))) (def-alien-type-method (array :type=) (type1 type2) (and (equal (alien-array-type-dimensions type1) (alien-array-type-dimensions type2)) (alien-type-= (alien-array-type-element-type type1) (alien-array-type-element-type type2)))) (def-alien-type-method (array :subtypep) (type1 type2) (and (alien-array-type-p type2) (let ((dim1 (alien-array-type-dimensions type1)) (dim2 (alien-array-type-dimensions type2))) (and (= (length dim1) (length dim2)) (or (and dim2 (null (car dim2)) (equal (cdr dim1) (cdr dim2))) (equal dim1 dim2)) (alien-subtype-p (alien-array-type-element-type type1) (alien-array-type-element-type type2)))))) ;;;; The RECORD type. (defstruct (alien-record-field (:print-function %print-alien-field) (:make-load-form-fun :just-dump-it-normally)) (name (required-argument) :type symbol) (type (required-argument) :type alien-type) (bits nil :type (or unsigned-byte null)) (offset 0 :type unsigned-byte)) (defun %print-alien-field (field stream depth) (declare (ignore depth)) (print-unreadable-object (field stream :type t) (funcall (formatter "~S ~S~@[:~D~]") stream (alien-record-field-type field) (alien-record-field-name field) (alien-record-field-bits field)))) (def-alien-type-class (record :include mem-block) (kind :struct :type (member :struct :union)) (name nil :type (or symbol null)) (fields nil :type list)) (def-alien-type-translator struct (name &rest fields) (parse-alien-record-type :struct name fields)) (def-alien-type-translator union (name &rest fields) (parse-alien-record-type :union name fields)) (defun parse-alien-record-type (kind name fields) (if fields (let* ((old (and name (auxiliary-alien-type kind name))) (result (if (or (null old) (alien-record-type-fields old)) (make-alien-record-type :name name :kind kind) old))) (when (and name (not (eq old result))) (setf (auxiliary-alien-type kind name) result)) (parse-alien-record-fields result fields) result) (if name (or (auxiliary-alien-type kind name) (setf (auxiliary-alien-type kind name) (make-alien-record-type :name name :kind kind))) (make-alien-record-type :kind kind)))) ;;; PARSE-ALIEN-RECORD-FIELDS -- internal ;;; ;;; Used by parse-alien-type to parse the fields of struct and union ;;; types. RESULT holds the record type we are parsing the fields of, ;;; and FIELDS is the list of field specifications. ;;; (defun parse-alien-record-fields (result fields) (declare (type alien-record-type result) (type list fields)) (let ((total-bits 0) (overall-alignment 1) (parsed-fields nil) (firstp t)) (dolist (field fields) (destructuring-bind (var type &optional bits) field (declare (ignore bits)) (let* ((field-type (parse-alien-type type)) (bits (alien-type-bits field-type)) (natural-alignment (alien-type-alignment field-type)) (alignment (embedded-alignment natural-alignment firstp)) (parsed-field (make-alien-record-field :type field-type :name var))) (push parsed-field parsed-fields) (when (null bits) (error (intl:gettext "Unknown size: ~S") (unparse-alien-type field-type))) (when (null alignment) (error (intl:gettext "Unknown alignment: ~S") (unparse-alien-type field-type))) (setf overall-alignment (max overall-alignment alignment)) (ecase (alien-record-type-kind result) (:struct (let ((offset (align-offset total-bits alignment))) (setf (alien-record-field-offset parsed-field) offset) (setf total-bits (+ offset bits)))) (:union (setf total-bits (max total-bits bits)))))) (setf firstp nil)) (let ((new (nreverse parsed-fields))) (setf (alien-record-type-fields result) new)) (setf (alien-record-type-alignment result) overall-alignment) (setf (alien-record-type-bits result) (align-offset total-bits overall-alignment)))) (def-alien-type-method (record :unparse) (type) `(,(case (alien-record-type-kind type) (:struct 'struct) (:union 'union) (t '???)) ,(alien-record-type-name type) ,@(unless (member type *record-types-already-unparsed* :test #'eq) (push type *record-types-already-unparsed*) (mapcar #'(lambda (field) `(,(alien-record-field-name field) ,(%unparse-alien-type (alien-record-field-type field)) ,@(if (alien-record-field-bits field) (list (alien-record-field-bits field))))) (alien-record-type-fields type))))) ;;; Test the record fields. Keep a hash table of already compared ;;; types to detect cycles. (defun record-fields-match-p (field1 field2) (and (eq (alien-record-field-name field1) (alien-record-field-name field2)) (eql (alien-record-field-bits field1) (alien-record-field-bits field2)) (eql (alien-record-field-offset field1) (alien-record-field-offset field2)) (alien-type-= (alien-record-field-type field1) (alien-record-field-type field2)))) (defvar *match-history* nil "A hash table used to detect cycles while comparing record types.") (defun in-match-history-or (type1 type2 alternative) "Test if TYPE1 and TYPE2 are in the *MATCH-HISTORY*. If so return true; otherwise call ALTERNATIVE." (cond (*match-history* (let ((list (gethash type1 *match-history*))) (cond ((memq type2 list) t) (t (setf (gethash type1 *match-history*) (cons type2 list)) (funcall alternative))))) (t (let ((*match-history* (make-hash-table :test #'eq))) (setf (gethash type1 *match-history*) (list type2)) (funcall alternative))))) (def-alien-type-method (record :type=) (type1 type2) (and (eq (alien-record-type-name type1) (alien-record-type-name type2)) (eq (alien-record-type-kind type1) (alien-record-type-kind type2)) (eql (alien-type-bits type1) (alien-type-bits type2)) (eql (alien-type-alignment type1) (alien-type-alignment type2)) (= (length (alien-record-type-fields type1)) (length (alien-record-type-fields type2))) (in-match-history-or type1 type2 (lambda () (every #'record-fields-match-p (alien-record-type-fields type1) (alien-record-type-fields type2)))))) ;;;; The FUNCTION and VALUES types. (defvar *values-type-okay* nil) (def-alien-type-class (function :include mem-block) (result-type (required-argument) :type alien-type) (arg-types (required-argument) :type list) (stub nil :type (or null function))) (def-alien-type-translator function (result-type &rest arg-types) (make-alien-function-type :result-type (let ((*values-type-okay* t)) (parse-alien-type result-type)) :arg-types (mapcar #'parse-alien-type arg-types))) (def-alien-type-method (function :unparse) (type) `(function ,(%unparse-alien-type (alien-function-type-result-type type)) ,@(mapcar #'%unparse-alien-type (alien-function-type-arg-types type)))) (def-alien-type-method (function :type=) (type1 type2) (and (alien-type-= (alien-function-type-result-type type1) (alien-function-type-result-type type2)) (= (length (alien-function-type-arg-types type1)) (length (alien-function-type-arg-types type2))) (every #'alien-type-= (alien-function-type-arg-types type1) (alien-function-type-arg-types type2)))) (def-alien-type-class (values) (values (required-argument) :type list)) (def-alien-type-translator values (&rest values) (unless *values-type-okay* (error (intl:gettext "Cannot use values types here."))) (let ((*values-type-okay* nil)) (make-alien-values-type :values (mapcar #'parse-alien-type values)))) (def-alien-type-method (values :unparse) (type) `(values ,@(mapcar #'%unparse-alien-type (alien-values-type-values type)))) (def-alien-type-method (values :type=) (type1 type2) (and (= (length (alien-values-type-values type1)) (length (alien-values-type-values type2))) (every #'alien-type-= (alien-values-type-values type1) (alien-values-type-values type2)))) ;;;; Alien variables. ;;; HEAP-ALIEN-INFO -- defstruct. ;;; ;;; Information describing a heap-allocated alien. ;;; (defstruct (heap-alien-info (:print-function %print-heap-alien-info) (:make-load-form-fun :just-dump-it-normally)) ;; The type of this alien. (type (required-argument) :type alien-type) ;; The form to evaluate to produce the SAP pointing to where in the heap ;; it is. (sap-form (required-argument))) ;;; (defun %print-heap-alien-info (info stream depth) (declare (ignore depth)) (print-unreadable-object (info stream :type t) (funcall (formatter "~S ~S") stream (heap-alien-info-sap-form info) (unparse-alien-type (heap-alien-info-type info))))) ;;; LOCAL-ALIEN-INFO -- public defstruct. ;;; ;;; Information about local aliens. The WITH-ALIEN macro builds one of these ;;; structures and local-alien and friends communicate information about how ;;; that local alien is represented. ;;; (defstruct (local-alien-info (:print-function %print-local-alien-info) (:make-load-form-fun :just-dump-it-normally) (:constructor make-local-alien-info (&key type force-to-memory-p))) ;; The type of the local alien. (type (required-argument) :type alien-type) ;; T if this local alien must be forced into memory. Using the ADDR macro ;; on a local alien will set this. (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type)) :type (member t nil))) ;;; (defun %print-local-alien-info (info stream depth) (declare (ignore depth)) (print-unreadable-object (info stream :type t) (funcall (formatter "~:[~;(forced to stack) ~]~S") stream (local-alien-info-force-to-memory-p info) (unparse-alien-type (local-alien-info-type info))))) ;;; GUESS-ALIEN-NAME-FROM-LISP-NAME -- internal. ;;; ;;; Make a string out of the symbol, converting all uppercase letters to ;;; lower case and hyphens into underscores. ;;; (defun guess-alien-name-from-lisp-name (lisp-name) (declare (type symbol lisp-name)) (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name)))) ;;; GUESS-LISP-NAME-FROM-ALIEN-NAME -- internal. ;;; ;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME. Make a symbol out of the ;;; string, converting all lowercase letters to uppercase and underscores into ;;; hyphens. ;;; (defun guess-lisp-name-from-alien-name (alien-name) (declare (type simple-string alien-name)) (intern (nsubstitute #\- #\_ (string-upcase alien-name)))) ;;; PICK-LISP-AND-ALIEN-NAMES -- internal. ;;; ;;; Extract the lisp and alien names from NAME. If only one is given, guess ;;; the other. ;;; (defun pick-lisp-and-alien-names (name) (etypecase name (string (values (guess-lisp-name-from-alien-name name) name)) (symbol (values name (guess-alien-name-from-lisp-name name))) (list (unless (= (length name) 2) (error (intl:gettext "Badly formed alien name."))) (values (cadr name) (car name))))) ;;; DEF-ALIEN-VARIABLE -- public ;;; (defmacro def-alien-variable (name type) "Define NAME as an external alien variable of type TYPE. NAME should be a list of a string holding the alien name and a symbol to use as the Lisp name. If NAME is just a symbol or string, then the other name is guessed from the one supplied." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types (let ((alien-type (parse-alien-type type))) `(eval-when (compile load eval) ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) (%def-alien-variable ',lisp-name ',alien-name ',alien-type)))))) ;;; %DEF-ALIEN-VARIABLE -- internal ;;; ;;; Do the actual work of DEF-ALIEN-VARIABLE. ;;; (defun %def-alien-variable (lisp-name alien-name type) (setf (info variable kind lisp-name) :alien) (setf (info variable where-from lisp-name) :defined) (clear-info variable constant-value lisp-name) (setf (info variable alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-address ,alien-name :flavor :data)))) ;;; EXTERN-ALIEN -- public. ;;; (defmacro extern-alien (name type) "Access the alien variable named NAME, assuming it is of type TYPE. This is SETFable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) `(%heap-alien ',(make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',alien-name :flavor ',flavor))))) ;;; WITH-ALIEN -- public. ;;; (defmacro with-alien (bindings &body body) "Establish some local alien variables. Each BINDING is of the form: VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. :STATIC The alien is allocated on the heap, and has infinate extent. The alien is allocated at load time, so the same piece of memory is used each time this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." (with-auxiliary-alien-types (dolist (binding (reverse bindings)) (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (let* ((alien-type (parse-alien-type type)) (flavor (if (alien-function-type-p alien-type) :code :data))) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) (case opt1 (:extern (values opt1 (guess-alien-name-from-lisp-name symbol))) (:static (values opt1 nil)) (t (values :local opt1)))) (setf body (ecase allocation #+nil (:static (let ((sap (make-symbol (concatenate 'string "SAP-FOR-" (symbol-name symbol))))) `((let ((,sap (load-time-value (%make-alien ...)))) (declare (type system-area-pointer ,sap)) (symbol-macrolet ((,symbol (sap-alien ,sap ,type))) ,@(when initial-value `((setq ,symbol ,initial-value))) ,@body))))) (:extern (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address ',initial-value :flavor ',flavor)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) (:local (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) (note-local-alien-type ',info ,var) (multiple-value-prog1 (symbol-macrolet ((,symbol (local-alien ',info ,var))) ,@(when initial-value `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var) ))))))))))) (verify-local-auxiliaries-okay) `(compiler-let ((*auxiliary-type-definitions* ',(append *new-auxiliary-types* *auxiliary-type-definitions*))) ,@body))) ;;;; Runtime C values that don't correspond directly to Lisp types. ;;; ALIEN-VALUE ;;; ;;; The defstruct for alien-value lives in struct.lisp 'cause it has to be ;;; real early in the cold-load order. ;;; (declaim (freeze-type alien-value)) ;;; (defun %print-alien-value (value stream depth) (declare (ignore depth)) (print-unreadable-object (value stream) (funcall (formatter "Alien ~S at #x~8,'0X") stream (unparse-alien-type (alien-value-type value)) (sap-int (alien-value-sap value))))) (declaim (inline null-alien)) (defun null-alien (x) "Return true if X (which must be an Alien pointer) is null, false otherwise." (zerop (sap-int (alien-sap x)))) (defmacro sap-alien (sap type) "Convert the System-Area-Pointer SAP to an Alien of the specified Type (not evaluated.) Type must be pointer-like." (let ((alien-type (parse-alien-type type))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) `(%sap-alien ,sap ',alien-type) (error (intl:gettext "Cannot make aliens of type ~S out of SAPs") type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) (type alien-type type)) (make-alien-value :sap sap :type type)) (defun alien-sap (alien) "Return a System-Area-Pointer pointing to Alien's data." (declare (type alien-value alien)) (alien-value-sap alien)) ;;;; Allocation/Deallocation of heap aliens. ;;; MAKE-ALIEN -- public. ;;; (defmacro make-alien (type &optional size) "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE is supplied, how it is interpreted depends on TYPE. If TYPE is an array type, SIZE is used as the first dimension for the allocated array. If TYPE is not an array, then SIZE is the number of elements to allocate. The memory is allocated using ``malloc'', so it can be passed to foreign functions which use ``free''." (let ((alien-type (if (alien-type-p type) type (parse-alien-type type)))) (multiple-value-bind (size-expr element-type) (if (alien-array-type-p alien-type) (let ((dims (alien-array-type-dimensions alien-type))) (cond (size (unless dims (error (intl:gettext "Cannot override the size of zero-dimensional arrays."))) (when (constantp size) (setf alien-type (copy-alien-array-type alien-type)) (setf (alien-array-type-dimensions alien-type) (cons (eval size) (cdr dims))))) (dims (setf size (car dims))) (t (setf size 1))) (values `(* ,size ,@(cdr dims)) (alien-array-type-element-type alien-type))) (values (or size 1) alien-type)) (let ((bits (alien-type-bits element-type)) (alignment (alien-type-alignment element-type))) (unless bits (error (intl:gettext "Size of ~S unknown.") (unparse-alien-type element-type))) (unless alignment (error (intl:gettext "Alignment of ~S unknown.") (unparse-alien-type element-type))) `(%sap-alien (%make-alien (* ,(align-offset bits alignment) ,size-expr)) ',(make-alien-pointer-type :to alien-type)))))) ;;; %MAKE-ALIEN -- internal ;;; ;;; Allocate a block of memory at least BITS bits long and return a system ;;; area pointer to it. ;;; (declaim (inline %make-alien)) (defun %make-alien (bits) (declare (type kernel:index bits) (optimize-interface (safety 2))) (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) (ash (the kernel:index (+ bits 7)) -3))) ;;; FREE-ALIEN -- public ;;; (declaim (inline free-alien)) (defun free-alien (alien) "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated by MAKE-ALIEN or ``malloc''." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) (alien-sap alien)) nil) ;;;; The SLOT operator ;;; SLOT-OR-LOSE -- internal. ;;; ;;; Find the field named SLOT, or die trying. ;;; (defun slot-or-lose (type slot) (declare (type alien-record-type type) (type symbol slot)) (or (find slot (alien-record-type-fields type) :key #'alien-record-field-name) (error (intl:gettext "No slot named ~S in ~S") slot type))) ;;; SLOT -- public ;;; ;;; Extract the value from the named slot from the record alien. If the ;;; alien is actually a pointer, then deref it first. ;;; (defun slot (alien slot) "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF." (declare (type alien-value alien) (type symbol slot) (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) (extract-alien-value (alien-value-sap alien) (alien-record-field-offset field) (alien-record-field-type field))))))) ;;; %SET-SLOT -- public setf method ;;; ;;; Deposit the value in the specified slot of the record alien. If the ;;; alien is really a pointer, deref it first. The compiler uses this ;;; when it can't figure out anything better. ;;; (defun %set-slot (alien slot value) (declare (type alien-value alien) (type symbol slot) (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) (deposit-alien-value (alien-value-sap alien) (alien-record-field-offset field) (alien-record-field-type field) value)))))) ;;; (defsetf slot %set-slot) ;;; %SLOT-ADDR -- internal ;;; ;;; Compute the address of the specified slot and return a pointer to it. ;;; (defun %slot-addr (alien slot) (declare (type alien-value alien) (type symbol slot) (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%slot-addr (deref alien) slot)) (alien-record-type (let* ((field (slot-or-lose type slot)) (offset (alien-record-field-offset field)) (field-type (alien-record-field-type field))) (%sap-alien (sap+ (alien-sap alien) (/ offset vm:byte-bits)) (make-alien-pointer-type :to field-type))))))) ;;;; The DEREF operator. ;;; DEREF-GUTS -- internal. ;;; ;;; Does most of the work of the different DEREF methods. Returns two values: ;;; the type and the offset (in bits) of the referenced alien. ;;; (defun deref-guts (alien indices) (declare (type alien-value alien) (type list indices) (values alien-type integer)) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (when (cdr indices) (error (intl:gettext "Too many indices when derefing ~S: ~D") type (length indices))) (let ((element-type (alien-pointer-type-to type))) (values element-type (if indices (* (align-offset (alien-type-bits element-type) (alien-type-alignment element-type)) (car indices)) 0)))) (alien-array-type (unless (= (length indices) (length (alien-array-type-dimensions type))) (error (intl:gettext "Incorrect number of indices when derefing ~S: ~D") type (length indices))) (labels ((frob (dims indices offset) (if (null dims) offset (frob (cdr dims) (cdr indices) (+ (if (zerop offset) 0 (* offset (car dims))) (car indices)))))) (let ((element-type (alien-array-type-element-type type))) (values element-type (* (align-offset (alien-type-bits element-type) (alien-type-alignment element-type)) (frob (alien-array-type-dimensions type) indices 0))))))))) ;;; DEREF -- public ;;; ;;; Dereference the alien and return the results. ;;; (defun deref (alien &rest indices) "De-reference an Alien pointer or array. If an array, the indices are used as the indices of the array element to access. If a pointer, one index can optionally be specified, giving the equivalent of C pointer arithmetic." (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (extract-alien-value (alien-value-sap alien) offset target-type))) ;;; %SET-DEREF -- public setf method ;;; (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (deposit-alien-value (alien-value-sap alien) offset target-type value))) ;;; (defsetf deref (alien &rest indices) (value) `(%set-deref ,alien ,value ,@indices)) ;;; %DEREF-ADDR -- public ;;; (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (%sap-alien (sap+ (alien-value-sap alien) (/ offset vm:byte-bits)) (make-alien-pointer-type :to target-type)))) ;;;; Accessing heap alien variables. (defun %heap-alien (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) (extract-alien-value (eval (heap-alien-info-sap-form info)) 0 (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) (deposit-alien-value (eval (heap-alien-info-sap-form info)) 0 (heap-alien-info-type info) value)) ;;; (defsetf %heap-alien %set-heap-alien) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) (%sap-alien (eval (heap-alien-info-sap-form info)) (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; Accessing local aliens. (defun make-local-alien (info) (let* ((alien (eval `(make-alien ,(local-alien-info-type info)))) (alien-sap (alien-sap alien))) (finalize alien #'(lambda () (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) alien-sap))) alien)) (defun note-local-alien-type (info alien) (declare (ignore info alien)) nil) (defun local-alien (info alien) (declare (ignore info)) (deref alien)) (defun %set-local-alien (info alien value) (declare (ignore info)) (setf (deref alien) value)) (define-setf-expander local-alien (&whole whole info alien) (let ((value (gensym)) (info (if (and (consp info) (eq (car info) 'quote)) (second info) (error (intl:gettext "Something is wrong; local-alien-info not found: ~S") whole)))) (values nil nil (list value) (if c:*converting-for-interpreter* `(%set-local-alien ',info ,alien ,value) `(if (%local-alien-forced-to-memory-p ',info) (%set-local-alien ',info ,alien ,value) (setf ,alien (deport ,value ',(local-alien-info-type info))))) whole))) (defun %local-alien-forced-to-memory-p (info) (local-alien-info-force-to-memory-p info)) (defun %local-alien-addr (info alien) (declare (type local-alien-info info)) (unless (local-alien-info-force-to-memory-p info) (error (intl:gettext "~S isn't forced to memory. Something went wrong.") alien)) alien) (defun dispose-local-alien (info alien) (declare (ignore info)) (cancel-finalization alien) (free-alien alien)) ;;;; The ADDR macro. (defmacro addr (expr &environment env) "Return an Alien pointer to the data addressed by Expr, which must be a call to SLOT or DEREF, or a reference to an Alien variable." (let ((form (macroexpand expr env))) (or (typecase form (cons (case (car form) (slot (cons '%slot-addr (cdr form))) (deref (cons '%deref-addr (cdr form))) (%heap-alien (cons '%heap-alien-addr (cdr form))) (local-alien (let ((info (let ((info-arg (second form))) (and (consp info-arg) (eq (car info-arg) 'quote) (second info-arg))))) (unless (local-alien-info-p info) (error (intl:gettext "Something is wrong, local-alien-info not found: ~S") form)) (setf (local-alien-info-force-to-memory-p info) t)) (cons '%local-alien-addr (cdr form))))) (symbol (let ((kind (info variable kind form))) (when (eq kind :alien) `(%heap-alien-addr ',(info variable alien-info form)))))) (error (intl:gettext "~S is not a valid L-value") form)))) ;;;; The CAST macro. (defmacro cast (alien type) "Convert ALIEN to an Alien of the specified TYPE (not evaluated). Both types must be Alien array, pointer or function types." `(%cast ,alien ',(parse-alien-type type))) (defun %cast (alien target-type) (declare (type alien-value alien) (type alien-type target-type) (optimize-interface (safety 2)) (optimize (inhibit-warnings 3))) (if (or (alien-pointer-type-p target-type) (alien-array-type-p target-type) (alien-function-type-p target-type)) (let ((alien-type (alien-value-type alien))) (if (or (alien-pointer-type-p alien-type) (alien-array-type-p alien-type) (alien-function-type-p alien-type)) (naturalize (alien-value-sap alien) target-type) (error (intl:gettext "~S cannot be cast.") alien))) (error (intl:gettext "Cannot cast to alien type ~S") (unparse-alien-type target-type)))) ;;;; The ALIEN-SIZE macro. (defmacro alien-size (type &optional (units :bits)) "Return the size of the alien type TYPE. UNITS specifies the units to use and can be either :BITS, :BYTES, or :WORDS." (let* ((alien-type (parse-alien-type type)) (bits (alien-type-bits alien-type))) (if bits (values (ceiling bits (ecase units (:bits 1) (:bytes vm:byte-bits) (:words vm:word-bits)))) (error (intl:gettext "Unknown size for alien type ~S.") (unparse-alien-type alien-type))))) ;;;; Naturalize, deport, extract-alien-value, deposit-alien-value (defun naturalize (alien type) (declare (type alien-type type)) (funcall (coerce (compute-naturalize-lambda type) 'function) alien type)) (defun deport (value type) (declare (type alien-type type)) (funcall (coerce (compute-deport-lambda type) 'function) value type)) (defun extract-alien-value (sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce (compute-extract-lambda type) 'function) sap offset type)) (defun deposit-alien-value (sap offset type value) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce (compute-deposit-lambda type) 'function) sap offset type value)) ;;;; alien-funcall, def-alien-function (defun alien-funcall (alien &rest args) "Call the foreign function ALIEN with the specified arguments. ALIEN's type specifies the argument and result types." (declare (type alien-value alien)) (let ((type (alien-value-type alien))) (typecase type (alien-pointer-type (apply #'alien-funcall (deref alien) args)) (alien-function-type (unless (= (length (alien-function-type-arg-types type)) (length args)) (error (intl:gettext "Wrong number of arguments for ~S~%Expected ~D, got ~D.") type (length (alien-function-type-arg-types type)) (length args))) (let ((stub (alien-function-type-stub type))) (unless stub (setf stub (let ((fun (gensym)) (parms (loop repeat (length args) collect (gensym)))) (compile nil `(lambda (,fun ,@parms) (declare (type (alien ,type) ,fun)) (alien-funcall ,fun ,@parms))))) (setf (alien-function-type-stub type) stub)) (apply stub alien args))) (t (error (intl:gettext "~S is not an alien function.") alien))))) (defmacro def-alien-routine (name result-type &rest args) "Def-Alien-Routine Name Result-Type {(Arg-Name Arg-Type [Style])}* Define a foreign interface function for the routine with the specified Name, which may be either a string, symbol or list of the form (string symbol). Return-Type is the Alien type for the function return value. VOID may be used to specify a function with no result. The remaining forms specify individual arguments that are passed to the routine. Arg-Name is a symbol that names the argument, primarily for documentation. Arg-Type is the C-Type of the argument. Style specifies the way that the argument is passed. :IN An :In argument is simply passed by value. The value to be passed is obtained from argument(s) to the interface function. No values are returned for :In arguments. This is the default mode. :OUT The specified argument type must be a pointer to a fixed sized object. A pointer to a preallocated object is passed to the routine, and the the object is accessed on return, with the value being returned from the interface function. :OUT and :IN-OUT cannot be used with pointers to arrays, records or functions. :COPY Similar to :IN, except that the argument values are stored in on the stack, and a pointer to the object is passed instead of the values themselves. :IN-OUT A combination of :OUT and :COPY. A pointer to the argument is passed, with the object being initialized from the supplied argument and the return value being determined by accessing the object on return." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (collect ((docs) (lisp-args) (arg-types) (alien-vars) (alien-args) (results)) (dolist (arg args) (if (stringp arg) (docs arg) (destructuring-bind (name type &optional (style :in)) arg (unless (member style '(:in :copy :out :in-out)) (error (intl:gettext "Bogus argument style ~S in ~S.") style arg)) (unless (eq style :out) (lisp-args name)) (when (and (member style '(:out :in-out)) (typep (parse-alien-type type) 'alien-pointer-type)) (error (intl:gettext "Can't use :out or :in-out on pointer-like type:~% ~S") type)) (cond ((eq style :in) (arg-types type) (alien-args name)) (t (arg-types `(* ,type)) (if (eq style :out) (alien-vars `(,name ,type)) (alien-vars `(,name ,type ,name))) (alien-args `(addr ,name)))) (when (or (eq style :out) (eq style :in-out)) (results name))))) `(defun ,lisp-name ,(lisp-args) ,@(docs) (with-alien ((,lisp-name (function ,result-type ,@(arg-types)) :extern ,alien-name) ,@(alien-vars)) ,(if (alien-values-type-p result-type) (let ((temps (loop repeat (length (alien-values-type-values result-type)) collect (gensym)))) `(multiple-value-bind ,temps (alien-funcall ,lisp-name ,@(alien-args)) (values ,@temps ,@(results)))) `(values (alien-funcall ,lisp-name ,@(alien-args)) ,@(results)))))))) cmucl-21a/src/code/alpha-vm.lisp000066400000000000000000000167661260377556400167000ustar00rootroot00000000000000;;; -*- Package: ALPHA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/alpha-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/code/alpha-vm.lisp $ ;;; ;;; This file contains the Alpha specific runtime stuff. ;;; (in-package "ALPHA") (use-package "SYSTEM") (use-package "ALIEN") (use-package "C-CALL") (intl:textdomain "cmucl") (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) ;;;; The sigcontext structure. (def-alien-type unix:sigcontext (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) (sc-pc system-area-pointer) (sc-ps unsigned-long) (sc-regs (array unsigned-long 32)) (sc-ownedfp unsigned-long) (sc-fpregs (array unsigned-long 32)) (sc-fpcr unsigned-long) (sc-fp-control unsigned-long) (sc-reserved1 unsigned-long) (sc-reserved2 unsigned-long) (sc-reserved3 unsigned-long) (sc-reserved4 unsigned-long) (sc-traparg-a0 unsigned-long) (sc-traparg-a1 unsigned-long) (sc-traparg-a2 unsigned-long) (sc-fp-trap-pc unsigned-long) ; imprecise pc (sc-fp-trigger-sum unsigned-long) (sc-fp-trigger-inst unsigned-long))) ;;;; Add machine specific features to *features* (pushnew :alpha *features*) ;;;; MACHINE-TYPE and MACHINE-VERSION (defun machine-type () "Returns a string describing the type of the local machine." "DECstation") (defun machine-version () "Returns a string describing the version of the local machine." "DECstation") ;;; FIXUP-CODE-OBJECT -- Interface ;;; (defun fixup-code-object (code offset value kind) (unless (zerop (rem offset word-bytes)) (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset)) (system:without-gcing (let ((sap (truly-the system-area-pointer (%primitive c::code-instructions code)))) (ecase kind (:jmp-hint (assert (zerop (ldb (byte 2 0) value))) #+nil (setf (sap-ref-16 sap offset) (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2))))) (:bits-63-48 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) (:bits-47-32 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) (:ldah (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) (:lda (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) ;;;; Internal-error-arguments. ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((pc (slot scp 'sc-pc))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-from-system-area pc (* vm:byte-bits 5) vector (* vm:word-bits vm:vector-data-offset) (* length vm:byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) (loop (when (>= index length) (return)) (sc-offsets (c::read-var-integer vector index))) (values error-number (sc-offsets)))))))) ;;;; Sigcontext access functions. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. ;;; (defun sigcontext-program-counter (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot scp 'sc-pc))) ;;; SIGCONTEXT-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; (defun sigcontext-register (scp index) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (deref (slot scp 'sc-regs) index))) (defun %set-sigcontext-register (scp index new) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (setf (deref (slot scp 'sc-regs) index) new) new)) (defsetf sigcontext-register %set-sigcontext-register) ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface. ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; (defun sigcontext-float-register (scp index format) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; ;;; Given a sigcontext pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot scp 'sc-fpcr))) ;;; EXTERN-ALIEN-NAME -- interface. ;;; ;;; The loader uses this to convert alien names to the form they occur in ;;; the symbol table (for example, prepending an underscore). On the MIPS, ;;; we don't do anything. ;;; (defun extern-alien-name (name) (declare (type simple-base-string name)) name) #+(and (or linux (and freebsd elf)) (not linkage-table)) (defun lisp::foreign-symbol-address-aux (name flavor) (declare (ignore flavor)) (multiple-value-bind (value found) (gethash name lisp::*foreign-symbols* 0) (if found value (multiple-value-bind (value found) (gethash (concatenate 'string "PVE_stub_" name) lisp::*foreign-symbols* 0) (if found value (let ((value (system:alternate-get-global-address name))) (when (zerop value) (error (intl:gettext "Unknown foreign symbol: ~S") name)) value)))))) ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; ;;; Do whatever is necessary to make the given code component executable. ;;; (defun sanctify-for-execution (component) (declare (ignore component)) (%primitive istream-memory-barrier)) cmucl-21a/src/code/amd64-vm.lisp000066400000000000000000000517141260377556400165160ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/code/amd64-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the AMD64 specific runtime stuff. ;;; ;;; Code movement fixups by Douglas T. Crosher, 1997. ;;; Thread support by Douglas T. Crosher, 1999. ;;; (in-package "AMD64") (use-package "SYSTEM") (use-package "ALIEN") (use-package "C-CALL") (use-package "KERNEL") (intl:textdomain "cmucl") (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) ;;;; The sigcontext structure. ;;;; Add machine specific features to *features* (pushnew :amd64 *features*) #+linux (def-alien-type nil (struct fpreg (significand (array unsigned-short 4)) (exponent unsigned-short))) #+linux (def-alien-type nil (struct fpstate (cw unsigned-long) (sw unsigned-long) (tag unsigned-long) (ipoff unsigned-long) (cssel unsigned-long) (dataoff unsigned-long) (datasel unsigned-long) (fpreg (array (struct fpreg) 8)) (status unsigned-long))) #+freebsd (def-alien-type unix:sigcontext (struct nil (sc-mask (array unsigned-int 4)) (sc-onstack unsigned-int) (sc-gs unsigned-int) (sc-fs unsigned-int) (sc-es unsigned-int) (sc-ds unsigned-int) (sc-edi unsigned-int) (sc-esi unsigned-int) (sc-fp unsigned-int) (sc-isp unsigned-int) (sc-ebx unsigned-int) (sc-edx unsigned-int) (sc-ecx unsigned-int) (sc-eax unsigned-int) (trapno unsigned-int) (err unsigned-int) (sc-pc unsigned-int) (sc-cs unsigned-int) (sc-efl unsigned-int) ; sc_ps (sc-sp unsigned-int) (sc-ss unsigned-int))) ;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux. #+openbsd (def-alien-type unix:sigcontext (struct nil (sc-gs unsigned-int) (sc-fs unsigned-int) (sc-es unsigned-int) (sc-ds unsigned-int) (sc-edi unsigned-int) (sc-esi unsigned-int) (sc-fp unsigned-int) ;; ebp (sc-ebx unsigned-int) (sc-edx unsigned-int) (sc-ecx unsigned-int) (sc-eax unsigned-int) (sc-pc unsigned-int) (sc-cs unsigned-int) (sc-efl unsigned-int) ; sc_ps (sc-sp unsigned-int) (sc-ss unsigned-int) (sc-onstack unsigned-int) (sc-mask unsigned-int) (sc-trapno unsigned-int) (sc-err unsigned-int) )) #+netbsd (def-alien-type unix:sigcontext (struct nil (sc-gs unsigned-int) (sc-fs unsigned-int) (sc-es unsigned-int) (sc-ds unsigned-int) (sc-edi unsigned-int) (sc-esi unsigned-int) (sc-fp unsigned-int) ;; ebp (sc-ebx unsigned-int) (sc-edx unsigned-int) (sc-ecx unsigned-int) (sc-eax unsigned-int) (sc-pc unsigned-int) (sc-cs unsigned-int) (sc-efl unsigned-int) ; sc_ps (sc-sp unsigned-int) (sc-ss unsigned-int) (sc-onstack unsigned-int) ;; Old NetBSD 1.3 signal mask (sc-oldmask unsigned-int) (sc-trapno unsigned-int) (sc-err unsigned-int) ;; New signal mask (post NetBSD 1.3) (sc-mask (array unsigned-int 4)) )) ;; For Linux... #+linux (def-alien-type unix:sigcontext (struct nil (sc-r8 unsigned-long) (sc-r9 unsigned-long) (sc-r10 unsigned-long) (sc-r11 unsigned-long) (sc-r12 unsigned-long) (sc-r13 unsigned-long) (sc-r14 unsigned-long) (sc-r15 unsigned-long) (sc-rdi unsigned-long) (sc-rsi unsigned-long) (rbp unsigned-long) (sc-rbx unsigned-long) (sc-rdx unsigned-long) (sc-rax unsigned-long) (sc-rcx unsigned-long) (sc-sp unsigned-long) (sc-pc unsigned-long) (sc-efl unsigned-long) (sc-cs unsigned-short) (gs unsigned-short) (fs unsigned-short) (__pad0 unsigned-short) (err unsigned-long) (trapno unsigned-long) (sc-mask unsigned-long) (cr2 unsigned-long) (fpstate (* (struct fpstate))) (__reserved1 (array unsigned-long 8)))) ;;;; MACHINE-TYPE and MACHINE-VERSION #-cross-compiler (defun machine-type () "Returns a string describing the type of the local machine." "AMD x86-64") #-cross-compiler (defun machine-version () "Returns a string describing the version of the local machine." "AMD x86-64") ;;; Fixup-Code-Object -- Interface ;;; ;;; This gets called by LOAD to resolve newly positioned objects ;;; with things (like code instructions) that have to refer to them. ;;; ;;; Add a fixup offset to the vector of fixup offsets for the given ;;; code object. ;;; ;;; Counter to measure the storage overhead. (defvar *num-fixups* 0) ;;; XXX (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (flet ((add-fixup (code offset) ;; Although this could check for and ignore fixups for code ;; objects in the read-only and static spaces, this should ;; only be the case when *enable-dynamic-space-code* is ;; True. (when lisp::*enable-dynamic-space-code* (incf *num-fixups*) (let ((fixups (code-header-ref code code-constants-offset))) (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) (let ((new-fixups (adjust-array fixups (1+ (length fixups)) :element-type '(unsigned-byte 32)))) (setf (aref new-fixups (length fixups)) offset) (setf (code-header-ref code code-constants-offset) new-fixups))) (t (unless (or (eq (get-type fixups) vm:unbound-marker-type) (zerop fixups)) (format t "** Init. code FU = ~s~%" fixups)) (setf (code-header-ref code code-constants-offset) (make-array 1 :element-type '(unsigned-byte 32) :initial-element offset)))))))) (system:without-gcing (let* ((sap (truly-the system-area-pointer (kernel:code-instructions code))) (obj-start-addr (logand (kernel:get-lisp-obj-address code) #xfffffff8)) #+nil (const-start-addr (+ obj-start-addr (* 5 4))) (code-start-addr (sys:sap-int (kernel:code-instructions code))) (ncode-words (kernel:code-header-ref code 1)) (code-end-addr (+ code-start-addr (* ncode-words 8)))) (unless (member kind '(:absolute :relative)) (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind)) (ecase kind (:absolute ;; Word at sap + offset contains a value to be replaced by ;; adding that value to fixup. (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) ;; Record absolute fixups that point within the code object. (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) (add-fixup code offset))) (:relative ;; Fixup is the actual address wanted. ;; ;; Record relative fixups that point outside the code ;; object. (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) (add-fixup code offset)) ;; Replace word with value to add to that loc to get there. (let* ((loc-sap (+ (sap-int sap) offset)) (rel-val (- fixup loc-sap 4))) (declare (type (unsigned-byte 32) loc-sap) (type (signed-byte 32) rel-val)) (setf (signed-sap-ref-32 sap offset) rel-val)))))) nil)) ;;; Do-Load-Time-Code-Fixups ;;; ;;; Add a code fixup to a code object generated by new-genesis. The ;;; fixup has already been applied, it's just a matter of placing the ;;; fixup in the code's fixup vector if necessary. ;;; #+gencgc (defun do-load-time-code-fixup (code offset fixup kind) (flet ((add-load-time-code-fixup (code offset) (let ((fixups (code-header-ref code vm:code-constants-offset))) (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) (let ((new-fixups (adjust-array fixups (1+ (length fixups)) :element-type '(unsigned-byte 32)))) (setf (aref new-fixups (length fixups)) offset) (setf (code-header-ref code vm:code-constants-offset) new-fixups))) (t (unless (or (eq (get-type fixups) vm:unbound-marker-type) (zerop fixups)) (%primitive print "** Init. code FU")) (setf (code-header-ref code vm:code-constants-offset) (make-array 1 :element-type '(unsigned-byte 32) :initial-element offset))))))) (let* ((sap (truly-the system-area-pointer (kernel:code-instructions code))) (obj-start-addr (logand (kernel:get-lisp-obj-address code) #xfffffff8)) (code-start-addr (sys:sap-int (kernel:code-instructions code))) (ncode-words (kernel:code-header-ref code 1)) (code-end-addr (+ code-start-addr (* ncode-words 8)))) (ecase kind (:absolute ;; Record absolute fixups that point within the ;; code object. (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) (add-load-time-code-fixup code offset))) (:relative ;; Record relative fixups that point outside the ;; code object. (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) (add-load-time-code-fixup code offset))))))) ;;;; Internal-error-arguments. ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((pc (int-sap (slot scp 'sc-pc)))) (declare (type system-area-pointer pc)) ;; using INT3 the pc is .. INT3 code length bytes... (let* ((length (sap-ref-8 pc 1)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-from-system-area pc (* vm:byte-bits 2) vector (* vm:word-bits vm:vector-data-offset) (* length vm:byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) (loop (when (>= index length) (return)) (sc-offsets (c::read-var-integer vector index))) (values error-number (sc-offsets)))))))) ;;;; Sigcontext access functions. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. ;;; (defun sigcontext-program-counter (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (int-sap (slot scp 'sc-pc)))) ;;; SIGCONTEXT-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; (defun sigcontext-register (scp index) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (case index ; ugly -- I know. (#.eax-offset (slot scp 'sc-eax)) (#.ecx-offset (slot scp 'sc-ecx)) (#.edx-offset (slot scp 'sc-edx)) (#.ebx-offset (slot scp 'sc-ebx)) (#.esp-offset (slot scp 'sc-sp)) (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp)) (#.esi-offset (slot scp 'sc-esi)) (#.edi-offset (slot scp 'sc-edi))))) (defun %set-sigcontext-register (scp index new) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (case index (#.eax-offset (setf (slot scp 'sc-eax) new)) (#.ecx-offset (setf (slot scp 'sc-ecx) new)) (#.edx-offset (setf (slot scp 'sc-edx) new)) (#.ebx-offset (setf (slot scp 'sc-ebx) new)) (#.esp-offset (setf (slot scp 'sc-sp) new)) (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new)) (#.esi-offset (setf (slot scp 'sc-esi) new)) (#.edi-offset (setf (slot scp 'sc-edi) new)))) new) (defsetf sigcontext-register %set-sigcontext-register) ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; #+linux (defun sigcontext-float-register (scp index format) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) 'fpreg) index)))) (coerce (sys:sap-ref-long reg-sap 0) format)))) ;;; Not supported on Free/OpenBSD because the floating point state is not ;;; saved. For now we assume this is true for all modern BSDs #+BSD (defun sigcontext-float-register (scp index format) (declare (ignore scp index)) (coerce 0l0 format)) #+linux (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0) 'fpreg) index)))) (declare (ignorable reg-sap)) #+not-yet (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float)) (coerce new-value format)))) ;;; Not supported on Free/OpenBSD. #+BSD (defun %set-sigcontext-float-register (scp index format new-value) (declare (ignore scp index)) (coerce new-value format)) ;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; ;;; Given a sigcontext pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; #+BSD (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp) (ignore scp)) ;; This is broken until some future release of FreeBSD/OpenBSD!!! (floating-point-modes)) #+linux (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp)) (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw)) (sw (slot (deref (slot scp 'fpstate) 0) 'sw))) ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw) ;; NOT TESTED -- clear sticky bits to clear interrupt condition (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f)) ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw)) ;; simulate floating-point-modes VOP (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))) ;;; EXTERN-ALIEN-NAME -- interface. ;;; ;;; The loader uses this to convert alien names to the form they occur in ;;; the symbol table (for example, prepending an underscore). ;;; (defun extern-alien-name (name) (declare (type simple-string name)) #+(and bsd (not elf)) (concatenate 'string "_" name) #-(and bsd (not elf)) name) #+(and (or linux (and freebsd elf)) (not linkage-table)) (defun lisp::foreign-symbol-address-aux (name flavor) (declare (ignore flavor)) (multiple-value-bind (value found) (gethash name lisp::*foreign-symbols* 0) (if found value (multiple-value-bind (value found) (gethash (concatenate 'string "PVE_stub_" name) lisp::*foreign-symbols* 0) (if found value (let ((value (system:alternate-get-global-address name))) (when (zerop value) (error (intl:gettext "Unknown foreign symbol: ~S") name)) value)))))) ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; ;;; Do whatever is necessary to make the given code component ;;; executable - nothing on the x86. ;;; (defun sanctify-for-execution (component) (declare (ignore component)) nil) ;;; FLOAT-WAIT ;;; ;;; This is used in error.lisp to ensure floating-point exceptions ;;; are properly trapped. The compiler translates this to a VOP. ;;; (defun float-wait() (float-wait)) ;;; FLOAT CONSTANTS ;;; ;;; These are used by the FP move-from-{single|double} VOPs rather ;;; than the i387 load constant instructions to avoid consing in some ;;; cases. Note these are initialised by genesis as they are needed ;;; early. ;;; (defvar *fp-constant-0s0*) (defvar *fp-constant-1s0*) (defvar *fp-constant-0d0*) (defvar *fp-constant-1d0*) ;;; The long-float constants. (defvar *fp-constant-0l0*) (defvar *fp-constant-1l0*) (defvar *fp-constant-pi*) (defvar *fp-constant-l2t*) (defvar *fp-constant-l2e*) (defvar *fp-constant-lg2*) (defvar *fp-constant-ln2*) ;;; Enable/disable scavenging of the read-only space. (defvar *scavenge-read-only-space* nil) ;;; The current alien stack pointer; saved/restored for non-local ;;; exits. (defvar *alien-stack*) ;;; Support for the MT19937 random number generator. The update ;;; function is implemented as an assembly routine. This definition is ;;; transformed to a call to this routine allowing its use in byte ;;; compiled code. ;;; (defun random-mt19937 (state) (declare (type (simple-array (unsigned-byte 32) (627)) state)) (random-mt19937 state)) ;;;; Useful definitions for writing thread safe code. (in-package "KERNEL") (export '(atomic-push-symbol-value atomic-pop-symbol-value atomic-pusha atomic-pushd atomic-push-vector)) (defun %instance-set-conditional (object slot test-value new-value) (declare (type instance object) (type index slot)) "Atomically compare object's slot value to test-value and if EQ store new-value in the slot. The original value of the slot is returned." (%instance-set-conditional object slot test-value new-value)) (defun set-symbol-value-conditional (symbol test-value new-value) (declare (type symbol symbol)) "Atomically compare symbol's value to test-value and if EQ store new-value in symbol's value slot and return the original value." (set-symbol-value-conditional symbol test-value new-value)) (defun rplaca-conditional (cons test-value new-value) (declare (type cons cons)) "Atomically compare the car of CONS to test-value and if EQ store new-value its car and return the original value." (rplaca-conditional cons test-value new-value)) (defun rplacd-conditional (cons test-value new-value) (declare (type cons cons)) "Atomically compare the cdr of CONS to test-value and if EQ store new-value its cdr and return the original value." (rplacd-conditional cons test-value new-value)) (defun data-vector-set-conditional (vector index test-value new-value) (declare (type simple-vector vector)) "Atomically compare an element of vector to test-value and if EQ store new-value the element and return the original value." (data-vector-set-conditional vector index test-value new-value)) (defmacro atomic-push-symbol-value (val symbol) "Thread safe push of val onto the list in the symbol global value." (ext:once-only ((n-val val)) (let ((new-list (gensym)) (old-list (gensym))) `(let ((,new-list (cons ,n-val nil))) (loop (let ((,old-list ,symbol)) (setf (cdr ,new-list) ,old-list) (when (eq (set-symbol-value-conditional ',symbol ,old-list ,new-list) ,old-list) (return ,new-list)))))))) (defmacro atomic-pop-symbol-value (symbol) "Thread safe pop from the list in the symbol global value." (let ((new-list (gensym)) (old-list (gensym))) `(loop (let* ((,old-list ,symbol) (,new-list (cdr ,old-list))) (when (eq (set-symbol-value-conditional ',symbol ,old-list ,new-list) ,old-list) (return (car ,old-list))))))) (defmacro atomic-pusha (val cons) "Thread safe push of val onto the list in the car of cons." (once-only ((n-val val) (n-cons cons)) (let ((new-list (gensym)) (old-list (gensym))) `(let ((,new-list (cons ,n-val nil))) (loop (let ((,old-list (car ,n-cons))) (setf (cdr ,new-list) ,old-list) (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list) ,old-list) (return ,new-list)))))))) (defmacro atomic-pushd (val cons) "Thread safe push of val onto the list in the cdr of cons." (once-only ((n-val val) (n-cons cons)) (let ((new-list (gensym)) (old-list (gensym))) `(let ((,new-list (cons ,n-val nil))) (loop (let ((,old-list (cdr ,n-cons))) (setf (cdr ,new-list) ,old-list) (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list) ,old-list) (return ,new-list)))))))) (defmacro atomic-push-vector (val vect index) "Thread safe push of val onto the list in the vector element." (once-only ((n-val val) (n-vect vect) (n-index index)) (let ((new-list (gensym)) (old-list (gensym))) `(let ((,new-list (cons ,n-val nil))) (loop (let ((,old-list (svref ,n-vect ,n-index))) (setf (cdr ,new-list) ,old-list) (when (eq (data-vector-set-conditional ,n-vect ,n-index ,old-list ,new-list) ,old-list) (return ,new-list)))))))) #+linkage-table (progn (defun lisp::foreign-symbol-address-aux (name flavor) (let ((entry-num (lisp::register-foreign-linkage name flavor))) (+ #.vm:target-foreign-linkage-space-start (* entry-num vm:target-foreign-linkage-entry-size)))) (defun lisp::find-foreign-symbol (addr) (declare (type (unsigned-byte 32) addr)) (when (>= addr vm:target-foreign-linkage-space-start) (let ((entry (/ (- addr vm:target-foreign-linkage-space-start) vm:target-foreign-linkage-entry-size))) (when (< entry (lisp::foreign-linkage-symbols)) (lisp::foreign-linkage-entry entry))))) ) cmucl-21a/src/code/array.lisp000066400000000000000000001414021260377556400162730ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/array.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions to implement arrays for CMU Common Lisp. ;;; Written by Skef Wholey. ;;; Worked over for the MIPS port by William Lott. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(array-rank-limit array-dimension-limit array-total-size-limit make-array vector aref array-element-type array-rank array-dimension array-dimensions array-in-bounds-p array-row-major-index array-total-size svref bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push vector-push-extend vector-pop adjust-array adjustable-array-p row-major-aref array-displacement)) (in-package "KERNEL") (export '(%with-array-data)) (in-package "LISP") (declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p array-displacement)) (defconstant array-rank-limit 65529 "The exclusive upper bound on the rank of an array.") (defconstant array-dimension-limit most-positive-fixnum "The exclusive upper bound any given dimension of an array.") (defconstant array-total-size-limit most-positive-fixnum "The exclusive upper bound on the total number of elements in an array.") ;;;; Random accessor functions. ;;; These functions are needed by the interpreter, 'cause the compiler inlines ;;; them. (macrolet ((frob (name) `(progn (defun ,name (array) (,name array)) (defun (setf ,name) (value array) (setf (,name array) value))))) (frob %array-fill-pointer) (frob %array-fill-pointer-p) (frob %array-available-elements) (frob %array-data-vector) (frob %array-displacement) (frob %array-displaced-p)) (defun %array-rank (array) (%array-rank array)) (defun %array-dimension (array axis) (%array-dimension array axis)) (defun %set-array-dimension (array axis value) (%set-array-dimension array axis value)) (defun %check-bound (array bound index) (declare (type index bound) (fixnum index)) (%check-bound array bound index)) ;;; %WITH-ARRAY-DATA -- Interface ;;; ;;; The guts of the WITH-ARRAY-DATA macro (in sysmacs). Note that this ;;; function is only called if we have an array header or an error, so it ;;; doesn't have to be too tense. ;;; (defun %with-array-data (array start end) (declare (array array) (type index start) (type (or index null) end) (values (simple-array * (*)) index index index)) (let* ((size (array-total-size array)) (end (cond (end (unless (<= end size) (error (intl:gettext "End ~D is greater than total size ~D.") end size)) end) (t size)))) (when (> start end) (error (intl:gettext "Start ~D is greater than end ~D.") start end)) (do ((data array (%array-data-vector data)) (cumulative-offset 0 (+ cumulative-offset (%array-displacement data)))) ((not (array-header-p data)) (values data (+ cumulative-offset start) (+ cumulative-offset end) cumulative-offset)) (declare (type index cumulative-offset))))) ;;;; MAKE-ARRAY (eval-when (:compile-toplevel :execute) (defmacro pick-type (type &rest specs) `(cond ,@(mapcar #'(lambda (spec) `(,(if (eq (car spec) t) t `(subtypep ,type ',(car spec))) ,@(cdr spec))) specs))) ); eval-when (defun %vector-type-code (type) (pick-type type (base-char (values #.vm:simple-string-type #.vm:char-bits)) (bit (values #.vm:simple-bit-vector-type 1)) ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2)) ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4)) ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8)) ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16)) ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32)) ((signed-byte 8) (values #.vm:simple-array-signed-byte-8-type 8)) ((signed-byte 16) (values #.vm:simple-array-signed-byte-16-type 16)) ((signed-byte 30) (values #.vm:simple-array-signed-byte-30-type 32)) ((signed-byte 32) (values #.vm:simple-array-signed-byte-32-type 32)) (single-float (values #.vm:simple-array-single-float-type 32)) (double-float (values #.vm:simple-array-double-float-type 64)) #+long-float (long-float (values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128)) #+double-double (double-double-float (values #.vm::simple-array-double-double-float-type 128)) ((complex single-float) (values #.vm:simple-array-complex-single-float-type 64)) ((complex double-float) (values #.vm:simple-array-complex-double-float-type 128)) #+long-float ((complex long-float) (values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256)) #+double-double ((complex double-double-float) (values #.vm::simple-array-complex-double-double-float-type 256)) (t (values #.vm:simple-vector-type #.vm:word-bits)))) (defun %complex-vector-type-code (type) (pick-type type (base-char #.vm:complex-string-type) (bit #.vm:complex-bit-vector-type) (t #.vm:complex-vector-type))) (defvar *static-vectors* nil "List of weak-pointers to static vectors. Needed for GCing static vectors") (defun make-static-vector (length element-type) (multiple-value-bind (type bits) (lisp::%vector-type-code element-type) ;; What types of static arrays do we really want to allow? ;; Whatever we choose, we definitely cannot allow arrays with the ;; following element types: T, (signed-byte 30) (unless (member type '(#.vm:simple-string-type #.vm:simple-array-unsigned-byte-8-type #.vm:simple-array-unsigned-byte-16-type #.vm:simple-array-unsigned-byte-32-type #.vm:simple-array-signed-byte-8-type #.vm:simple-array-signed-byte-16-type #.vm:simple-array-signed-byte-32-type #.vm:simple-array-single-float-type #.vm:simple-array-double-float-type #.vm:simple-array-complex-single-float-type #.vm:simple-array-complex-double-float-type)) (error (intl:gettext "Cannot make a static array of element type ~S") element-type)) ;; Malloc space for the vector. We need enough space for the data ;; itself, and then 2 words for the vector header (header word and ;; length). Use calloc to make sure the area is initialized to ;; zeros, like normal Lisp arrays are. (let* ((data-bytes (ceiling (* length bits) 8)) (total-bytes (+ data-bytes (* 2 vm:word-bytes)))) (sys:without-gcing (let ((pointer (alien:alien-funcall (alien:extern-alien "calloc" (function sys::system-area-pointer unix::size-t unix::size-t)) total-bytes 1))) ;; Malloc should return double-word (8 byte) alignment. (assert (zerop (logand 7 (sys:sap-int pointer)))) (when (zerop (sys:sap-int pointer)) (error (intl:gettext "Failed to allocate space for static array of length ~S of type ~S") length element-type)) ;; Fill in the vector header word and length word. Set the data ;; portion of the header word (normally 0) to 1 so we know this ;; is a static vector. (setf (sys:sap-ref-32 pointer 0) (+ type (ash 1 vm:type-bits))) (setf (sys:sap-ref-32 pointer vm:word-bytes) (ash length 2)) ;; Convert the sap to a lisp object and initialize the array (let ((vector (kernel:make-lisp-obj (+ vm:other-pointer-type (sys:sap-int pointer))))) (push (make-weak-pointer vector) *static-vectors*) vector)))))) (defun make-array (dimensions &key (element-type t) (initial-element nil initial-element-p) (initial-contents nil initial-contents-p) adjustable fill-pointer displaced-to displaced-index-offset allocation) "Creates an array of the specified Dimensions and properties. See the manual for details. :Element-type The type of objects that the array can hold :Initial-element Each element of the array is initialized to this value, if supplied. If not supplied, 0 of the appropriate type is used. :Initial-contents The contents of the array are initialized to this. :Adjustable If non-Nil, make an expressly adjustable array. :Fill-pointer For one-dimensional array, set the fill-pointer to the given value. If T, use the actual length of the array. :Displaced-to Create an array that is displaced to the target array specified by :displaced-to. :Displaced-index-offset Index offset to the displaced array. That is, index 0 of this array is actually index displaced-index-offset of the target displaced array. :Allocation How to allocate the array. If :MALLOC, a static, nonmovable array is created. This array is created by calling malloc." (declare (type (member nil :malloc) allocation)) (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) (array-rank (length (the list dimensions))) (static-array-p (eq allocation :malloc)) (simple (and (null fill-pointer) (not adjustable) (null displaced-to)))) (declare (fixnum array-rank)) (when (and displaced-index-offset (null displaced-to)) (error (intl:gettext "Can't specify :displaced-index-offset without :displaced-to"))) (when (and adjustable static-array-p) (error (intl:gettext "Cannot make an adjustable static array"))) (when (and displaced-to static-array-p) (error (intl:gettext "Cannot make a displaced array static"))) (if (and simple (= array-rank 1)) ;; It's a (simple-array * (*)) (multiple-value-bind (type bits) (%vector-type-code element-type) (declare (type (unsigned-byte 8) type) (type (integer 1 256) bits)) (let* ((length (car dimensions)) (array (if static-array-p (make-static-vector length element-type) (allocate-vector type length (ceiling (* (if (= type vm:simple-string-type) (1+ length) length) bits) vm:word-bits))))) (declare (type index length)) (when initial-element-p (fill array initial-element)) (when initial-contents-p (when initial-element-p (error (intl:gettext "Cannot specify both :initial-element and ~ :initial-contents"))) (unless (= length (length initial-contents)) (error (intl:gettext "~D elements in the initial-contents, but the ~ vector length is ~D.") (length initial-contents) length)) (replace array initial-contents)) array)) ;; It's either a complex array or a multidimensional array. (let* ((total-size (reduce #'* dimensions)) (data (or displaced-to (data-vector-from-inits dimensions total-size element-type initial-contents initial-contents-p initial-element initial-element-p static-array-p))) (array (make-array-header (cond ((= array-rank 1) (%complex-vector-type-code element-type)) (simple vm:simple-array-type) (t vm:complex-array-type)) array-rank))) (cond (fill-pointer (unless (= array-rank 1) (error (intl:gettext "Only vectors can have fill pointers."))) (let ((length (car dimensions))) (declare (fixnum length)) (setf (%array-fill-pointer array) (cond ((eq fill-pointer t) length) (t (unless (and (fixnump fill-pointer) (>= fill-pointer 0) (<= fill-pointer length)) (error (intl:gettext "Invalid fill-pointer ~D") fill-pointer)) fill-pointer)))) (setf (%array-fill-pointer-p array) t)) (t (setf (%array-fill-pointer array) total-size) (setf (%array-fill-pointer-p array) nil))) (setf (%array-available-elements array) total-size) (setf (%array-data-vector array) data) (cond (displaced-to (when (or initial-element-p initial-contents-p) (error (intl:gettext "Neither :initial-element nor :initial-contents ~ can be specified along with :displaced-to"))) ;; The CLHS entry for MAKE-ARRAY says that if the ;; actual array element types are not type equivalent ;; (subtypes of each other), the consequences are ;; undefined. Let's signal an error here. (unless (and (subtypep (upgraded-array-element-type element-type) (array-element-type displaced-to)) (subtypep (array-element-type displaced-to) (upgraded-array-element-type element-type))) (error (intl:gettext "One can't displace an array of type ~S into ~ another of type ~S.") element-type (array-element-type displaced-to))) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) (error (intl:gettext "~S doesn't have enough elements.") displaced-to)) (setf (%array-displacement array) offset) (setf (%array-displaced-p array) t))) (t (setf (%array-displaced-p array) nil))) (let ((axis 0)) (dolist (dim dimensions) (setf (%array-dimension array axis) dim) (incf axis))) array)))) (defvar *debug-static-array-p* nil "If non-NIL, print some debugging information when GC'ing static arrays") (defun static-array-p (array) (with-array-data ((v array) (start) (end)) (declare (ignore start end)) (and (typep v '(kernel:simple-unboxed-array (*))) (let ((header (sys:sap-ref-32 (sys:vector-sap v) (- (* 2 vm:word-bytes))))) (logbitp vm:type-bits header))))) (defun free-static-vector (vector) (sys:without-gcing (let ((addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address vector)))) (when *debug-static-array-p* (format t (intl:gettext "~&Freeing foreign vector at #x~X~%") addr)) (alien:alien-funcall (alien:extern-alien "free" (function c-call:void sys:system-area-pointer)) (sys:int-sap addr))))) (defun finalize-static-vectors () ;; Run down the list of weak-pointers to static vectors. Look at ;; the static vector and see if vector is marked. If so, clear the ;; mark, and do nothing. If the mark is not set, then the vector is ;; free, so free it, and remove this weak-pointer from the list. ;; The mark bit the MSB of the header word. Look at scavenge in ;; gencgc.c. (when *static-vectors* (when *debug-static-array-p* (let ((*print-array* nil)) (format t (intl:gettext "Finalizing static vectors ~S~%") *static-vectors*))) (setf *static-vectors* (delete-if #'(lambda (wp) (let ((vector (weak-pointer-value wp))) (when vector (let* ((sap (sys:vector-sap vector)) (header (sys:sap-ref-32 sap (* -2 vm:word-bytes)))) (when *debug-static-array-p* (format t (intl:gettext "static vector ~A. header = ~X~%") vector header)) (cond ((logbitp 31 header) ;; Clear mark (setf (sys:sap-ref-32 sap (* -2 vm:word-bytes)) (logand header #x7fffffff)) (when *debug-static-array-p* (let ((*print-array* nil)) (format t (intl:gettext " static vector ~A in use~%") vector))) nil) (t ;; Mark was clear so free the vector (when *debug-static-array-p* (let ((*print-array* nil)) (format t (intl:gettext " Free static vector ~A~%") vector))) (sys:without-interrupts (setf (weak-pointer-value wp) nil) (free-static-vector vector)) t)))))) *static-vectors*)))) ;; Clean up any unreferenced static vectors after GC has run. (pushnew 'finalize-static-vectors *after-gc-hooks*) ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array ;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR ;;; for error checking on the structure of initial-contents. ;;; (defun data-vector-from-inits (dimensions total-size element-type initial-contents initial-contents-p initial-element initial-element-p &optional static-array-p) (when (and initial-contents-p initial-element-p) (error (intl:gettext "Cannot supply both :initial-contents and :initial-element to either make-array or adjust-array."))) (let ((data (if static-array-p (make-static-vector total-size element-type) (if initial-element-p (make-array total-size :element-type element-type :initial-element initial-element) (make-array total-size :element-type element-type))))) (cond (initial-element-p (unless (and (simple-vector-p data) static-array-p) (unless (typep initial-element element-type) (error (intl:gettext "~S cannot be used to initialize an array of type ~S.") initial-element element-type)) (fill (the vector data) initial-element))) (initial-contents-p (fill-data-vector data dimensions initial-contents))) data)) (defun fill-data-vector (vector dimensions initial-contents) (let ((index 0)) (labels ((frob (axis dims contents) (cond ((null dims) (setf (aref vector index) contents) (incf index)) (t (unless (typep contents 'sequence) (error (intl:ngettext "Malformed :initial-contents. ~S is not a ~ sequence, but ~D more layer needed." "Malformed :initial-contents. ~S is not a ~ sequence, but ~D more layers needed." (- (length dimensions) axis)) contents)) (unless (= (length contents) (car dims)) (error (intl:gettext "Malformed :initial-contents. Dimension of ~ axis ~D is ~D, but ~S is ~D long.") axis (car dims) contents (length contents))) (if (listp contents) (dolist (content contents) (frob (1+ axis) (cdr dims) content)) (dotimes (i (length contents)) (frob (1+ axis) (cdr dims) (aref contents i)))))))) (frob 0 dimensions initial-contents)))) (defun vector (&rest objects) "Constructs a simple-vector from the given objects." (coerce (the list objects) 'simple-vector)) ;;;; Accessor/Setter functions. (defun data-vector-ref (array index) (with-array-data ((vector array) (index index) (end)) (declare (ignore end) (optimize (safety 3))) (macrolet ((dispatch (&rest stuff) `(etypecase vector ,@(mapcar #'(lambda (type) (let ((atype `(simple-array ,type (*)))) `(,atype (data-vector-ref (the ,atype vector) index)))) stuff)))) (dispatch t bit character (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) (signed-byte 8) (signed-byte 16) (signed-byte 30) (signed-byte 32) single-float double-float #+long-float long-float #+double-double double-double-float (complex single-float) (complex double-float) #+long-float (complex long-float) #+double-double (complex double-double-float))))) (defun data-vector-set (array index new-value) (with-array-data ((vector array) (index index) (end)) (declare (ignore end) (optimize (safety 3))) (macrolet ((dispatch (&rest stuff) `(etypecase vector ,@(mapcar #'(lambda (type) (let ((atype `(simple-array ,type (*)))) `(,atype (data-vector-set (the ,atype vector) index (the ,type new-value)) new-value))) stuff)))) (dispatch t bit character (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) (signed-byte 8) (signed-byte 16) (signed-byte 30) (signed-byte 32) single-float double-float #+long-float long-float #+double-double double-double-float (complex single-float) (complex double-float) #+long-float (complex long-float) #+double-double (complex double-double-float))))) (defun %array-row-major-index (array subscripts &optional (invalid-index-error-p t)) (declare (array array) (list subscripts)) (let ((rank (array-rank array))) (unless (= rank (length subscripts)) (simple-program-error (intl:gettext "Wrong number of subscripts, ~D, for array of rank ~D") (length subscripts) rank)) (if (array-header-p array) (do ((subs (nreverse subscripts) (cdr subs)) (axis (1- (array-rank array)) (1- axis)) (chunk-size 1) (result 0)) ((null subs) result) (declare (list subs) (fixnum axis chunk-size result)) (let ((index (car subs)) (dim (%array-dimension array axis))) (declare (fixnum index dim)) (unless (< -1 index dim) (if invalid-index-error-p (error (intl:gettext "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S") index axis array) (return-from %array-row-major-index nil))) (incf result (* chunk-size index)) (setf chunk-size (* chunk-size dim)))) (let ((index (first subscripts))) (unless (< -1 index (length (the (simple-array * (*)) array))) (if invalid-index-error-p (error (intl:gettext "Invalid index ~D in ~S") index array) (return-from %array-row-major-index nil))) index)))) (defun array-in-bounds-p (array &rest subscripts) "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." (if (%array-row-major-index array subscripts nil) t)) (defun array-row-major-index (array &rest subscripts) (%array-row-major-index array subscripts)) (defun aref (array &rest subscripts) "Returns the element of the Array specified by the Subscripts." (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) (let ((subscripts (butlast stuff)) (new-value (car (last stuff)))) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value))) (declaim (inline (setf aref))) (defun (setf aref) (new-value array &rest subscripts) (declare (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) (defun row-major-aref (array index) "Returns the element of array corressponding to the row-major index. This is SETF'able." (declare (optimize (safety 1))) (row-major-aref array index)) (defun %set-row-major-aref (array index new-value) (declare (optimize (safety 1))) (setf (row-major-aref array index) new-value)) (defun svref (simple-vector index) "Returns the Index'th element of the given Simple-Vector." (declare (optimize (safety 1))) (aref simple-vector index)) (defun %svset (simple-vector index new) (declare (optimize (safety 1))) (setf (aref simple-vector index) new)) (defun bit (bit-array &rest subscripts) "Returns the bit from the Bit-Array at the specified Subscripts." (declare (type (array bit) bit-array) (optimize (safety 1))) (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) (defun %bitset (bit-array &rest stuff) (declare (type (array bit) bit-array) (optimize (safety 1))) (let ((subscripts (butlast stuff)) (new-value (car (last stuff)))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value))) (declaim (inline (setf bit))) (defun (setf bit) (new-value bit-array &rest subscripts) (declare (type (array bit) bit-array) (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) (defun sbit (simple-bit-array &rest subscripts) "Returns the bit from the Simple-Bit-Array at the specified Subscripts." (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) (row-major-aref simple-bit-array (%array-row-major-index simple-bit-array subscripts))) (defun %sbitset (simple-bit-array &rest stuff) (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) (let ((subscripts (butlast stuff)) (new-value (car (last stuff)))) (setf (row-major-aref simple-bit-array (%array-row-major-index simple-bit-array subscripts)) new-value))) (declaim (inline (setf sbit))) (defun (setf sbit) (new-value bit-array &rest subscripts) (declare (type (simple-array bit) bit-array) (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) ;;;; Random array properties. (defun array-element-type (array) "Returns the type of the elements of the array" (let ((type (get-type array))) (macrolet ((pick-element-type (&rest stuff) `(cond ,@(mapcar #'(lambda (stuff) (cons (let ((item (car stuff))) (cond ((eq item t) t) ((listp item) (cons 'or (mapcar #'(lambda (x) `(= type ,x)) item))) (t `(= type ,item)))) (cdr stuff))) stuff)))) (pick-element-type ((vm:simple-string-type vm:complex-string-type) 'base-char) ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit) (vm:simple-vector-type t) (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2)) (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4)) (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8)) (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16)) (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32)) (vm:simple-array-signed-byte-8-type '(signed-byte 8)) (vm:simple-array-signed-byte-16-type '(signed-byte 16)) (vm:simple-array-signed-byte-30-type '(signed-byte 30)) (vm:simple-array-signed-byte-32-type '(signed-byte 32)) (vm:simple-array-single-float-type 'single-float) (vm:simple-array-double-float-type 'double-float) #+long-float (vm:simple-array-long-float-type 'long-float) #+double-double (vm::simple-array-double-double-float-type 'double-double-float) (vm:simple-array-complex-single-float-type '(complex single-float)) (vm:simple-array-complex-double-float-type '(complex double-float)) #+long-float (vm:simple-array-complex-long-float-type '(complex long-float)) #+double-double (vm::simple-array-complex-double-double-float-type '(complex double-double-float)) ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type) (with-array-data ((array array) (start) (end)) (declare (ignore start end)) (array-element-type array))) (t (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) "Returns the number of dimensions of the Array." (if (array-header-p array) (%array-rank array) 1)) (defun array-dimension (array axis-number) "Returns length of dimension Axis-Number of the Array." (declare (array array) (type index axis-number)) (cond ((not (array-header-p array)) (unless (= axis-number 0) (simple-program-error (intl:gettext "Vector axis is not zero: ~S") axis-number)) (length (the (simple-array * (*)) array))) ((>= axis-number (%array-rank array)) (simple-program-error (intl:ngettext "~D is too big; ~S only has ~D dimension" "~D is too big; ~S only has ~D dimensions" (%array-rank array)) axis-number array)) (t (%array-dimension array axis-number)))) (defun array-dimensions (array) "Returns a list whose elements are the dimensions of the array" (declare (array array)) (if (array-header-p array) (do ((results nil (cons (array-dimension array index) results)) (index (1- (array-rank array)) (1- index))) ((minusp index) results)) (list (array-dimension array 0)))) (defun array-total-size (array) "Returns the total number of elements in the Array." (declare (array array)) (if (array-header-p array) (%array-available-elements array) (length (the vector array)))) (defun array-displacement (array) "Returns values of :displaced-to and :displaced-index-offset options to make-array, or the defaults nil and 0 if not a displaced array." (declare (array array)) (if (and (array-header-p array) (%array-displaced-p array)) (values (%array-data-vector array) (truly-the fixnum (%array-displacement array))) (values nil 0))) (defun adjustable-array-p (array) "Returns T if (adjust-array array...) would return an array identical to the argument, this happens for complex arrays." (declare (array array)) (not (typep array 'simple-array))) ;;;; Fill pointer frobbing stuff. (defun array-has-fill-pointer-p (array) "Returns T if the given Array has a fill pointer, or Nil otherwise." (declare (array array)) (and (array-header-p array) (%array-fill-pointer-p array))) (defun fill-pointer (vector) "Returns the Fill-Pointer of the given Vector." (declare (vector vector)) (if (and (array-header-p vector) (%array-fill-pointer-p vector)) (%array-fill-pointer vector) (error 'simple-type-error :datum vector :expected-type '(and vector (satisfies array-has-fill-pointer-p)) :format-control (intl:gettext "~S is not an array with a fill-pointer.") :format-arguments (list vector)))) (defun %set-fill-pointer (vector new) (declare (vector vector) (fixnum new)) (if (and (array-header-p vector) (%array-fill-pointer-p vector)) (if (> new (%array-available-elements vector)) (simple-program-error (intl:gettext "New fill pointer, ~S, is larger than the length of the vector.") new) (setf (%array-fill-pointer vector) new)) (error 'simple-type-error :datum vector :expected-type '(and vector (satisfies array-has-fill-pointer-p)) :format-control (intl:gettext "~S is not an array with a fill-pointer.") :format-arguments (list vector)))) (defun vector-push (new-el array) "Attempts to set the element of Array designated by the fill pointer to New-El and increment fill pointer by one. If the fill pointer is too large, Nil is returned, otherwise the index of the pushed element is returned." (declare (vector array)) (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (cond ((= fill-pointer (%array-available-elements array)) nil) (t (setf (aref array fill-pointer) new-el) (setf (%array-fill-pointer array) (1+ fill-pointer)) fill-pointer)))) (defun vector-push-extend (new-el array &optional (extension (if (zerop (length array)) 1 (length array)))) "Like Vector-Push except that if the fill pointer gets too large, the Array is extended rather than Nil being returned." (declare (vector array) (fixnum extension)) (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (when (= fill-pointer (%array-available-elements array)) (setf array (adjust-array array (+ fill-pointer extension)))) (setf (aref array fill-pointer) new-el) (setf (%array-fill-pointer array) (1+ fill-pointer)) fill-pointer)) (defun vector-pop (array) "Attempts to decrease the fill-pointer by 1 and return the element pointer to by the new fill pointer. If the original value of the fill pointer is 0, an error occurs." (declare (vector array)) (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (if (zerop fill-pointer) (simple-program-error (intl:gettext "Nothing left to pop.")) (aref array (setf (%array-fill-pointer array) (1- fill-pointer)))))) ;;;; Adjust-array (defun adjust-array (array dimensions &key (element-type (array-element-type array)) (initial-element nil initial-element-p) (initial-contents nil initial-contents-p) fill-pointer displaced-to displaced-index-offset) "Adjusts the Array's dimensions to the given Dimensions and stuff." (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) (cond ((/= (the fixnum (length (the list dimensions))) (the fixnum (array-rank array))) (simple-program-error (intl:gettext "Number of dimensions not equal to rank of array."))) ((not (subtypep element-type (array-element-type array))) (simple-program-error (intl:gettext "New element type, ~S, is incompatible with old.") element-type)) ((static-array-p array) (simple-program-error (intl:gettext "Static arrays are not adjustable.")))) (let ((array-rank (length (the list dimensions)))) (declare (fixnum array-rank)) (when (and fill-pointer (> array-rank 1)) (simple-program-error (intl:gettext "Multidimensional arrays can't have fill pointers."))) (cond (initial-contents-p ;; Array former contents replaced by initial-contents. (if (or initial-element-p displaced-to) (simple-program-error (intl:gettext "Initial contents may not be specified with ~ the :initial-element or :displaced-to option."))) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type initial-contents initial-contents-p initial-element initial-element-p))) (if (adjustable-array-p array) (set-array-header array array-data array-size (get-new-fill-pointer array array-size fill-pointer) 0 dimensions nil) (if (array-header-p array) ;; Simple multidimensional or single dimensional array. (make-array dimensions :element-type element-type :initial-contents initial-contents) array-data)))) (displaced-to ;; No initial-contents supplied is already established. (when initial-element (simple-program-error (intl:gettext "The :initial-element option may not be specified ~ with :displaced-to."))) (unless (subtypep element-type (array-element-type displaced-to)) (simple-program-error (intl:gettext "One can't displace an array of type ~S into another of ~ type ~S.") element-type (array-element-type displaced-to))) (let ((displacement (or displaced-index-offset 0)) (array-size (apply #'* dimensions))) (declare (fixnum displacement array-size)) (if (< (the fixnum (array-total-size displaced-to)) (the fixnum (+ displacement array-size))) (simple-program-error (intl:gettext "The :displaced-to array is too small."))) (if (adjustable-array-p array) ;; None of the original contents appear in adjusted array. (set-array-header array displaced-to array-size (get-new-fill-pointer array array-size fill-pointer) displacement dimensions t) ;; Simple multidimensional or single dimensional array. (make-array dimensions :element-type element-type :displaced-to displaced-to :displaced-index-offset displaced-index-offset)))) ((= array-rank 1) (let ((old-length (array-total-size array)) (new-length (car dimensions)) new-data) (declare (fixnum old-length new-length)) (with-array-data ((old-data array) (old-start) (old-end old-length)) (cond ((and (adjustable-array-p array) (not (%array-displaced-p array)) (<= new-length old-length)) ;; Shrink underlying vector in-place. We don't do this ;; for non-adjustable arrays, since that might confuse ;; user expectations about adjust-array consing a fresh ;; array in that case. (setf new-data (shrink-vector old-data new-length))) (t (setf new-data (data-vector-from-inits dimensions new-length element-type initial-contents initial-contents-p initial-element initial-element-p)) (replace new-data old-data :start2 old-start :end2 old-end))) (if (adjustable-array-p array) (set-array-header array new-data new-length (get-new-fill-pointer array new-length fill-pointer) 0 dimensions nil) new-data)))) (t (let ((old-length (%array-available-elements array)) (new-length (apply #'* dimensions))) (declare (fixnum old-length new-length)) (cond ((null dimensions) array) (t (with-array-data ((old-data array) (old-start) (old-end old-length)) (declare (ignore old-end)) (let ((new-data (if (or (%array-displaced-p array) (> new-length old-length)) (data-vector-from-inits dimensions new-length element-type () nil initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length)) (when initial-element-p (fill new-data initial-element)) (zap-array-data old-data (array-dimensions array) old-start new-data dimensions new-length element-type initial-element initial-element-p)) (if (adjustable-array-p array) (set-array-header array new-data new-length new-length 0 dimensions nil) (let ((new-array (make-array-header vm:simple-array-type array-rank))) (set-array-header new-array new-data new-length new-length 0 dimensions nil))))))))))))) (defun get-new-fill-pointer (old-array new-array-size fill-pointer) (cond ((not fill-pointer) (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) (simple-program-error (intl:gettext "Cannot adjust-array an array (~S) to a size (~S) that is ~ smaller than it's fill pointer (~S).") old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) ((not (array-has-fill-pointer-p old-array)) (simple-program-error (intl:gettext "Cannot supply a non-NIL value (~S) for :fill-pointer ~ in adjust-array unless the array (~S) was originally ~ created with a fill pointer.") fill-pointer old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) (simple-program-error (intl:gettext "Cannot supply a value for :fill-pointer (~S) that is larger ~ than the new length of the vector (~S).") fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) new-array-size) (t (simple-program-error (intl:gettext "Bogus value for :fill-pointer in adjust-array: ~S") fill-pointer)))) (defun shrink-vector (vector new-size) "Destructively alters the Vector, changing its length to New-Size, which must be less than or equal to its current size." (declare (vector vector)) (unless (array-header-p vector) (macrolet ((frob (name &rest things) `(etypecase ,name ,@(mapcar #'(lambda (thing) `(,(car thing) (fill (truly-the ,(car thing) ,name) ,(cadr thing) :start new-size))) things)))) (frob vector (simple-vector 0) (simple-base-string (code-char 0)) (simple-bit-vector 0) ((simple-array (unsigned-byte 2) (*)) 0) ((simple-array (unsigned-byte 4) (*)) 0) ((simple-array (unsigned-byte 8) (*)) 0) ((simple-array (unsigned-byte 16) (*)) 0) ((simple-array (unsigned-byte 32) (*)) 0) ((simple-array (signed-byte 8) (*)) 0) ((simple-array (signed-byte 16) (*)) 0) ((simple-array (signed-byte 30) (*)) 0) ((simple-array (signed-byte 32) (*)) 0) ((simple-array single-float (*)) (coerce 0 'single-float)) ((simple-array double-float (*)) (coerce 0 'double-float)) #+long-float ((simple-array long-float (*)) (coerce 0 'long-float)) #+double-double ((simple-array double-double-float (*)) (coerce 0 'double-double-float)) ((simple-array (complex single-float) (*)) (coerce 0 '(complex single-float))) ((simple-array (complex double-float) (*)) (coerce 0 '(complex double-float))) #+long-float ((simple-array (complex long-float) (*)) (coerce 0 '(complex long-float))) #+double-double ((simple-array (complex double-double-float) (*)) (coerce 0 '(complex double-double-float)))))) ;; Only arrays have fill-pointers, but vectors have their length parameter ;; in the same place. (setf (%array-fill-pointer vector) new-size) vector) (defun set-array-header (array data length fill-pointer displacement dimensions &optional displacedp) "Fills in array header with provided information. Returns array." (setf (%array-data-vector array) data) (setf (%array-available-elements array) length) (cond (fill-pointer (setf (%array-fill-pointer array) fill-pointer) (setf (%array-fill-pointer-p array) t)) (t (setf (%array-fill-pointer array) length) (setf (%array-fill-pointer-p array) nil))) (setf (%array-displacement array) displacement) (if (listp dimensions) (dotimes (axis (array-rank array)) (declare (type index axis)) (setf (%array-dimension array axis) (pop dimensions))) (setf (%array-dimension array 0) dimensions)) (setf (%array-displaced-p array) displacedp) array) ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY. ;;; Make a temporary to be used when old-data and new-data are EQ. ;;; (defvar *zap-array-data-temp* (make-array 1000 :initial-element t)) (defun zap-array-data-temp (length element-type initial-element initial-element-p) (declare (fixnum length)) (when (> length (the fixnum (length *zap-array-data-temp*))) (setf *zap-array-data-temp* (make-array length :initial-element t))) (when initial-element-p (unless (typep initial-element element-type) (simple-program-error (intl:gettext "~S cannot be used to initialize an array of type ~S.") initial-element element-type)) (fill (the simple-vector *zap-array-data-temp*) initial-element :end length)) *zap-array-data-temp*) ;;; ZAP-ARRAY-DATA -- Internal. ;;; ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the ;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an ;;; arrangement specified by the New-Dims. Offset is a displaced offset to be ;;; added to computed indexes of Old-Data. New-Length, Element-Type, ;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data ;;; are EQ; in this case, a temporary must be used and filled appropriately. ;;; When Old-Data and New-Data are not EQ, New-Data has already been filled ;;; with any specified initial-element. ;;; (defun zap-array-data (old-data old-dims offset new-data new-dims new-length element-type initial-element initial-element-p) (declare (list old-dims new-dims)) (setq old-dims (nreverse old-dims)) (setq new-dims (reverse new-dims)) (if (eq old-data new-data) (let ((temp (zap-array-data-temp new-length element-type initial-element initial-element-p))) (zap-array-data-aux old-data old-dims offset temp new-dims) (dotimes (i new-length) (setf (aref new-data i) (aref temp i)))) (zap-array-data-aux old-data old-dims offset new-data new-dims))) (defun zap-array-data-aux (old-data old-dims offset new-data new-dims) (declare (fixnum offset)) (let ((limits (mapcar #'(lambda (x y) (declare (fixnum x y)) (1- (the fixnum (min x y)))) old-dims new-dims))) (macrolet ((bump-index-list (index limits) `(do ((subscripts ,index (cdr subscripts)) (limits ,limits (cdr limits))) ((null subscripts) nil) (cond ((< (the fixnum (car subscripts)) (the fixnum (car limits))) (rplaca subscripts (1+ (the fixnum (car subscripts)))) (return ,index)) (t (rplaca subscripts 0)))))) (do ((index (make-list (length old-dims) :initial-element 0) (bump-index-list index limits))) ((null index)) (setf (aref new-data (row-major-index-from-dims index new-dims)) (aref old-data (+ (the fixnum (row-major-index-from-dims index old-dims)) offset))))))) ;;; ROW-MAJOR-INDEX-FROM-DIMS -- Internal. ;;; ;;; This figures out the row-major-order index of an array reference from a ;;; list of subscripts and a list of dimensions. This is for internal calls ;;; only, and the subscripts and dim-list variables are assumed to be reversed ;;; from what the user supplied. ;;; (defun row-major-index-from-dims (rev-subscripts rev-dim-list) (do ((rev-subscripts rev-subscripts (cdr rev-subscripts)) (rev-dim-list rev-dim-list (cdr rev-dim-list)) (chunk-size 1) (result 0)) ((null rev-dim-list) result) (declare (fixnum chunk-size result)) (setq result (+ result (the fixnum (* (the fixnum (car rev-subscripts)) chunk-size)))) (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list)))))) ;;;; Some bit stuff. (defun bit-array-same-dimensions-p (array1 array2) (declare (type (array bit) array1 array2)) (and (= (array-rank array1) (array-rank array2)) (dotimes (index (array-rank array1) t) (when (/= (array-dimension array1 index) (array-dimension array2 index)) (return nil))))) (defun pick-result-array (result-bit-array bit-array-1) (case result-bit-array ((t) bit-array-1) ((nil) (make-array (array-dimensions bit-array-1) :element-type 'bit :initial-element 0)) (t (unless (bit-array-same-dimensions-p bit-array-1 result-bit-array) (simple-program-error (intl:gettext "~S and ~S do not have the same dimensions.") bit-array-1 result-bit-array)) result-bit-array))) (defmacro def-bit-array-op (name function) (let ((docstring (format nil "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ All the arrays must have the same rank and dimensions." (symbol-name function)))) (intl::note-translatable intl::*default-domain* docstring) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) ,docstring (declare (type (array bit) bit-array-1 bit-array-2) (type (or (array bit) (member t nil)) result-bit-array)) (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) (simple-program-error (intl:gettext "~S and ~S do not have the same dimensions.") bit-array-1 bit-array-2)) (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) (if (and (simple-bit-vector-p bit-array-1) (simple-bit-vector-p bit-array-2) (simple-bit-vector-p result-bit-array)) (locally (declare (optimize (speed 3) (safety 0))) (,name bit-array-1 bit-array-2 result-bit-array)) (with-array-data ((data1 bit-array-1) (start1) (end1)) (declare (ignore end1)) (with-array-data ((data2 bit-array-2) (start2) (end2)) (declare (ignore end2)) (with-array-data ((data3 result-bit-array) (start3) (end3)) (do ((index-1 start1 (1+ index-1)) (index-2 start2 (1+ index-2)) (index-3 start3 (1+ index-3))) ((>= index-3 end3) result-bit-array) (declare (type index index-1 index-2 index-3)) (setf (sbit data3 index-3) (logand (,function (sbit data1 index-1) (sbit data2 index-2)) 1))))))))))) (def-bit-array-op bit-and logand) (def-bit-array-op bit-ior logior) (def-bit-array-op bit-xor logxor) (def-bit-array-op bit-eqv logeqv) (def-bit-array-op bit-nand lognand) (def-bit-array-op bit-nor lognor) (def-bit-array-op bit-andc1 logandc1) (def-bit-array-op bit-andc2 logandc2) (def-bit-array-op bit-orc1 logorc1) (def-bit-array-op bit-orc2 logorc2) (defun bit-not (bit-array &optional result-bit-array) "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is created. Both arrays must have the same rank and dimensions." (declare (type (array bit) bit-array) (type (or (array bit) (member t nil)) result-bit-array)) (let ((result-bit-array (pick-result-array result-bit-array bit-array))) (if (and (simple-bit-vector-p bit-array) (simple-bit-vector-p result-bit-array)) (locally (declare (optimize (speed 3) (safety 0))) (bit-not bit-array result-bit-array)) (with-array-data ((src bit-array) (src-start) (src-end)) (declare (ignore src-end)) (with-array-data ((dst result-bit-array) (dst-start) (dst-end)) (do ((src-index src-start (1+ src-index)) (dst-index dst-start (1+ dst-index))) ((>= dst-index dst-end) result-bit-array) (declare (type index src-index dst-index)) (setf (sbit dst dst-index) (logxor (sbit src src-index) 1)))))))) cmucl-21a/src/code/backq.lisp000066400000000000000000000263421260377556400162430ustar00rootroot00000000000000;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/backq.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. ;;; (unparsing by Miles Bader) ;;; (in-package "LISP") (intl:textdomain "cmucl") ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: ;;; ;;; |`,|: [a] => a ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL ;;; T: [a] => a ;the T flag is used when a is self-evaluating ;;; QUOTE: [a] => (QUOTE a) ;;; APPEND: [a] => (APPEND . a) ;;; NCONC: [a] => (NCONC . a) ;;; LIST: [a] => (LIST . a) ;;; LIST*: [a] => (LIST* . a) ;;; ;;; The flags are combined according to the following set of rules: ;;; ([a] means that a should be converted according to the previous table) ;;; ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| ;;;cdr \ || | T or NIL | | ;;;================================================================================ ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) ;;; NIL || LIST ([a]) | QUOTE (a) | a | a ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) ;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) ;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) ;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) ;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) ;;; ;;; involves starting over again pretending you had read ".,a)" instead ;;; of ",@a)" (defvar *backquote-count* 0 "How deep we are into backquotes") (defvar *bq-comma-flag* '(|,|)) (defvar *bq-at-flag* '(|,@|)) (defvar *bq-dot-flag* '(|,.|)) (defvar *bq-vector-flag* '(|bqv|)) (defvar *bq-tokens* '(backq-comma backq-comma-at backq-comma-dot backq-list backq-list* backq-append backq-nconc backq-cons backq-vector)) ;; This is the actual character macro. (defun backquote-macro (stream ignore) (declare (ignore ignore)) (let ((*backquote-count* (1+ *backquote-count*))) (multiple-value-bind (flag thing) (backquotify stream (read stream t nil t)) (if (eq flag *bq-at-flag*) (%reader-error stream (intl:gettext ",@ after backquote in ~S") thing)) (if (eq flag *bq-dot-flag*) (%reader-error stream (intl:gettext ",. after backquote in ~S") thing)) (values (backquotify-1 flag thing) 'list)))) (defun comma-macro (stream ignore) (declare (ignore ignore)) (unless (> *backquote-count* 0) (when *read-suppress* (return-from comma-macro nil)) (%reader-error stream (intl:gettext "Comma not inside a backquote."))) (let ((c (read-char stream)) (*backquote-count* (1- *backquote-count*))) (values (cond ((char= c #\@) (cons *bq-at-flag* (read stream t nil t))) ((char= c #\.) (cons *bq-dot-flag* (read stream t nil t))) (t (unread-char c stream) (cons *bq-comma-flag* (read stream t nil t)))) 'list))) ;;; (defun expandable-backq-expression-p (object) (and (consp object) (let ((flag (car object))) (or (eq flag *bq-at-flag*) (eq flag *bq-dot-flag*))))) ;;; This does the expansion from table 2. (defun backquotify (stream code) (cond ((atom code) (cond ((null code) (values nil nil)) ((or (consp code) (symbolp code)) ;; Keywords are self evaluating. Install after packages. (values 'quote code)) (t (values t code)))) ((or (eq (car code) *bq-at-flag*) (eq (car code) *bq-dot-flag*)) (values (car code) (cdr code))) ((eq (car code) *bq-comma-flag*) (comma (cdr code))) ((eq (car code) *bq-vector-flag*) (multiple-value-bind (dflag d) (backquotify stream (cdr code)) (values 'vector (backquotify-1 dflag d)))) (t (multiple-value-bind (aflag a) (backquotify stream (car code)) (multiple-value-bind (dflag d) (backquotify stream (cdr code)) (if (eq dflag *bq-at-flag*) ;; get the errors later. (%reader-error stream (intl:gettext ",@ after dot in ~S") code)) (if (eq dflag *bq-dot-flag*) (%reader-error stream (intl:gettext ",. after dot in ~S") code)) (cond ((eq aflag *bq-at-flag*) (if (null dflag) (if (expandable-backq-expression-p a) (values 'append (list a)) (comma a)) (values 'append (cond ((eq dflag 'append) (cons a d )) (t (list a (backquotify-1 dflag d))))))) ((eq aflag *bq-dot-flag*) (if (null dflag) (if (expandable-backq-expression-p a) (values 'nconc (list a)) (comma a)) (values 'nconc (cond ((eq dflag 'nconc) (cons a d)) (t (list a (backquotify-1 dflag d))))))) ((null dflag) (if (memq aflag '(quote t nil)) (values 'quote (list a)) (values 'list (list (backquotify-1 aflag a))))) ((memq dflag '(quote t)) (if (memq aflag '(quote t nil)) (values 'quote (cons a d )) (values 'list* (list (backquotify-1 aflag a) (backquotify-1 dflag d))))) (t (setq a (backquotify-1 aflag a)) (if (memq dflag '(list list*)) (values dflag (cons a d)) (values 'list* (list a (backquotify-1 dflag d))))))))))) ;;; This handles the cases (defun comma (code) (cond ((atom code) (cond ((null code) (values nil nil)) ((or (numberp code) (eq code 't)) (values t code)) (t (values *bq-comma-flag* code)))) ((and (eq (car code) 'quote) (not (expandable-backq-expression-p (cadr code)))) (values (car code) (cadr code))) ((memq (car code) '(append list list* nconc)) (values (car code) (cdr code))) ((eq (car code) 'cons) (values 'list* (cdr code))) (t (values *bq-comma-flag* code)))) ;;; This handles table 1. (defun backquotify-1 (flag thing) (cond ((or (eq flag *bq-comma-flag*) (memq flag '(t nil))) thing) ((eq flag 'quote) (list 'quote thing)) ((eq flag 'list*) (cond ((and (null (cddr thing)) (not (expandable-backq-expression-p (cadr thing)))) (cons 'backq-cons thing)) ((expandable-backq-expression-p (car (last thing))) (list 'backq-append (cons 'backq-list (butlast thing)) ;; Can it be optimized further? -- APD, 2001-12-21 (car (last thing)))) (t (cons 'backq-list* thing)))) ((eq flag 'vector) (list 'backq-vector thing)) (t (cons (cdr (assq flag '((cons . backq-cons) (list . backq-list) (append . backq-append) (nconc . backq-nconc)))) thing)))) ;;;; Magic backq- versions of builtin functions. ;;; Use synonyms for the lisp functions we use, so we can recognize backquoted ;;; material when pretty-printing (defun backq-list (&rest args) args) (defun backq-list* (&rest args) (apply #'list* args)) (defun backq-append (&rest args) (apply #'append args)) (defun backq-nconc (&rest args) (apply #'nconc args)) (defun backq-cons (x y) (cons x y)) (macrolet ((frob (b-name name) `(define-compiler-macro ,b-name (&rest args) `(,',name ,@args)))) (frob backq-list list) (frob backq-list* list*) (frob backq-append append) (frob backq-nconc nconc) (frob backq-cons cons)) (defun backq-vector (list) (declare (list list)) (coerce list 'simple-vector)) ;;;; Unparsing (defun backq-unparse-expr (form splicing) (ecase splicing ((nil) `(backq-comma ,form)) ((t) `((backq-comma-at ,form))) (:nconc `((backq-comma-dot ,form))) )) (defun backq-unparse (form &optional splicing) "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*, BACKQ-APPEND, etc. produced by the backquote reader macro, will return a corresponding backquote input form. In this form, `,' `,@' and `,.' are represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma. SPLICING indicates whether a comma-escape return should be modified for splicing with other forms: a value of T or :NCONC meaning that an extra level of parentheses should be added." (cond ((atom form) (backq-unparse-expr form splicing)) ((not (null (cdr (last form)))) (intl:gettext "### illegal dotted backquote form ###")) (t (case (car form) (backq-list (mapcar #'backq-unparse (cdr form))) (backq-list* (do ((tail (cdr form) (cdr tail)) (accum nil)) ((null (cdr tail)) (nconc (nreverse accum) (backq-unparse (car tail) t))) (push (backq-unparse (car tail)) accum))) (backq-append (mapcar #'(lambda (el) (backq-unparse el t)) (cdr form))) (backq-nconc (mapcar #'(lambda (el) (backq-unparse el :nconc)) (cdr form))) (backq-cons (cons (backq-unparse (cadr form) nil) (backq-unparse (caddr form) t))) (backq-vector (coerce (backq-unparse (cadr form)) 'vector)) (quote (cadr form)) (t (backq-unparse-expr form splicing)))))) (defun pprint-backquote (stream form &rest noise) (declare (ignore noise)) (write-char #\` stream) (write (backq-unparse form) :stream stream)) (defun pprint-backq-comma (stream form &rest noise) (declare (ignore noise)) (ecase (car form) (backq-comma (write-char #\, stream) ;; We want to write ", @foo" and not ",@foo"! The latter is ;; wrong if the variable is @foo. Same for ", .foo"; ",.foo" ;; would be wrong if the symbol is .foo. Do we need to check for ;; the symbol-package? If we don't we'll just put a space that ;; isn't needed, so it seems harmless. (when (symbolp (cadr form)) (let ((first-char (char (symbol-name (cadr form)) 0))) (when (or (char= #\@ first-char) (char= #\. first-char)) (write-char #\space stream))))) (backq-comma-at (princ ",@" stream)) (backq-comma-dot (princ ",." stream))) (write (cadr form) :stream stream)) ;;;; BACKQ-INIT and BACKQ-PP-INIT (set-macro-character #\` #'backquote-macro) (set-macro-character #\, #'comma-macro) ;;; BACKQ-PP-INIT -- interface. ;;; ;;; This is called by PPRINT-INIT. This must be seperate from BACKQ-INIT ;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded. ;;; (defun backq-pp-init () (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote) (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma) (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma) (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma)) cmucl-21a/src/code/bignum-test.lisp000066400000000000000000000060401260377556400174110ustar00rootroot00000000000000;;;; -*- Package: Bignum -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/bignum-test.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Some stuff to check that bignum operations are retuning the correct ;;; results. ;;; (in-package "BIGNUM") (defvar *in-bignum-wrapper* nil) (defmacro def-bignum-wrapper (name lambda-list &body body) (let ((var-name (ext:symbolicate "*OLD-" name "*")) (wrap-name (ext:symbolicate "WRAP-" name)) (args (mapcar #'(lambda (x) (if (listp x) (car x) x)) (remove-if #'(lambda (x) (member x lambda-list-keywords)) lambda-list)))) `(progn (defvar ,var-name (fdefinition ',name)) (defun ,wrap-name ,lambda-list (if *in-bignum-wrapper* (funcall ,var-name ,@args) (let ((*in-bignum-wrapper* t)) ,@body))) (setf (fdefinition ',name) #',wrap-name)))) (defun big= (x y) (= (if (typep x 'bignum) (%normalize-bignum x (%bignum-length x)) x) (if (typep y 'bignum) (%normalize-bignum y (%bignum-length y)) y))) (def-bignum-wrapper add-bignums (x y) (let ((res (funcall *old-add-bignums* x y))) (assert (big= (- res y) x)) res)) (def-bignum-wrapper multiply-bignums (x y) (let ((res (funcall *old-multiply-bignums* x y))) (if (zerop x) (assert (zerop res)) (multiple-value-bind (q r) (truncate res x) (assert (and (zerop r) (big= q y))))) res)) (def-bignum-wrapper negate-bignum (x &optional (fully-normalized t)) (let ((res (funcall *old-negate-bignum* x fully-normalized))) (assert (big= (- res) x)) res)) (def-bignum-wrapper subtract-bignum (x y) (let ((res (funcall *old-subtract-bignum* x y))) (assert (big= (+ res y) x)) res)) (def-bignum-wrapper multiply-bignum-and-fixnum (x y) (let ((res (funcall *old-multiply-bignum-and-fixnum* x y))) (if (zerop x) (assert (zerop res)) (multiple-value-bind (q r) (truncate res x) (assert (and (zerop r) (big= q y))))) res)) (def-bignum-wrapper multiply-fixnums (x y) (let ((res (funcall *old-multiply-fixnums* x y))) (if (zerop x) (assert (zerop res)) (multiple-value-bind (q r) (truncate res x) (assert (and (zerop r) (big= q y))))) res)) (def-bignum-wrapper bignum-ashift-right (x shift) (let ((res (funcall *old-bignum-ashift-right* x shift))) (assert (big= (ash res shift) (logand x (ash -1 shift)))) res)) (def-bignum-wrapper bignum-ashift-left (x shift) (let ((res (funcall *old-bignum-ashift-left* x shift))) (assert (big= (ash res (- shift)) x)) res)) (def-bignum-wrapper bignum-truncate (x y) (multiple-value-bind (q r) (funcall *old-bignum-truncate* x y) (assert (big= (+ (* q y) r) x)) (values q r))) (def-bignum-wrapper bignum-compare (x y) (let ((res (funcall *old-bignum-compare* x y))) (assert (big= (signum (- x y)) res)) res)) cmucl-21a/src/code/bignum.lisp000066400000000000000000004016531260377556400164450ustar00rootroot00000000000000;;; -*- Mode: Lisp; Log: code.log; Package: bignum -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/bignum.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains code to implement bignum support. ;;; (in-package "BIGNUM") (use-package "KERNEL") (intl:textdomain "cmucl") ;;; These symbols define the interface to the number code. (export '(add-bignums multiply-bignums negate-bignum subtract-bignum multiply-bignum-and-fixnum multiply-fixnums bignum-ashift-right bignum-ashift-left bignum-gcd bignum-to-float bignum-integer-length bignum-logical-and bignum-logical-ior bignum-logical-xor bignum-logical-not bignum-load-byte bignum-deposit-byte bignum-truncate bignum-plus-p bignum-compare make-small-bignum bignum-logcount bignum-logbitp)) ;;; These symbols define the interface to the compiler. (export '(bignum-type bignum-element-type bignum-index %allocate-bignum %bignum-length %bignum-set-length %bignum-ref %bignum-set %digit-0-or-plusp %add-with-carry %subtract-with-borrow %multiply-and-add %multiply %lognot %logand %logior %logxor %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl %ashr %digit-logical-shift-right)) ;;;; Notes. ;;; The following interfaces will either be assembler routines or code sequences ;;; expanded into the code as basic bignum operations: ;;; General: ;;; %BIGNUM-LENGTH ;;; %ALLOCATE-BIGNUM ;;; %BIGNUM-REF ;;; %NORMALIZE-BIGNUM ;;; %BIGNUM-SET-LENGTH ;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN ;;; %SIGN-DIGIT ;;; %ASHR ;;; %ASHL ;;; %BIGNUM-0-OR-PLUSP ;;; %DIGIT-LOGICAL-SHIFT-RIGHT ;;; General (May not exist when done due to sole use in %-routines.) ;;; %DIGIT-0-OR-PLUSP ;;; Addition: ;;; %ADD-WITH-CARRY ;;; Subtraction: ;;; %SUBTRACT-WITH-BORROW ;;; Multiplication ;;; %MULTIPLY ;;; Negation ;;; %LOGNOT ;;; Shifting (in place) ;;; %NORMALIZE-BIGNUM-BUFFER ;;; GCD/Relational operators: ;;; %DIGIT-COMPARE ;;; %DIGIT-GREATER ;;; Relational operators: ;;; %LOGAND ;;; %LOGIOR ;;; %LOGXOR ;;; LDB ;;; %FIXNUM-TO-DIGIT ;;; TRUNCATE ;;; %FLOOR ;;; ;;; ;;; Note: The floating routines know about the float representation. ;;; ;;; PROBLEM 1: ;;; There might be a problem with various LET's and parameters that take a ;;; digit value. We need to write these so those things stay in 32-bit ;;; registers and number stack slots. I bind locals to these values, and I ;;; use function on them -- ZEROP, ASH, etc. ;;; ;;; PROBLEM 2: ;;; In shifting and byte operations, I use masks and logical operations that ;;; could result in intermediate bignums. This is hidden by the current system, ;;; but I may need to write these in a way that keeps these masks and logical ;;; operations from diving into the Lisp level bignum code. ;;; ;;; To do: ;;; fixnums ;;; logior, logxor, logand ;;; depending on relationals, < (twice) and <= (twice) ;;; or write compare thing (twice). ;;; LDB on fixnum with bignum result. ;;; DPB on fixnum with bignum result. ;;; TRUNCATE returns zero or one as one value and fixnum or minus fixnum ;;; for the other value when given (truncate fixnum bignum). ;;; Returns (truncate bignum fixnum) otherwise. ;;; addition ;;; subtraction (twice) ;;; multiply ;;; GCD ;;; write MASK-FIELD and DEPOSIT-FIELD in terms of logical operations. ;;; DIVIDE ;;; IF (/ x y) with bignums: ;;; do the truncate, and if rem is 0, return quotient. ;;; if rem is non-0 ;;; gcd of x and y. ;;; "truncate" each by gcd, ignoring remainder 0. ;;; form ratio of each result, bottom is positive. ;;; ;;;; What's a bignum? (eval-when (compile load eval) ;Necessary for DEFTYPE. (defconstant digit-size #+amd64 64 #-amd64 32) (defconstant maximum-bignum-length (1- (ash 1 (- 32 vm:type-bits)))) ) ;eval-when ;;;; Internal inline routines. ;;; %ALLOCATE-BIGNUM must zero all elements. ;;; (defun %allocate-bignum (length) (declare (type bignum-index length)) (%allocate-bignum length)) ;;; Extract the length of the bignum. ;;; (defun %bignum-length (bignum) (declare (type bignum-type bignum)) (%bignum-length bignum)) ;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs ;;; to be able to return 32 bits somewhere no one looks for real objects. ;;; (defun %bignum-ref (bignum i) (declare (type bignum-type bignum) (type bignum-index i)) (%bignum-ref bignum i)) ;;; (defun %bignum-set (bignum i value) (declare (type bignum-type bignum) (type bignum-index i) (type bignum-element-type value)) (%bignum-set bignum i value)) ;;; (defsetf %bignum-ref %bignum-set) ;;; Return T if digit is positive, or NIL if negative. ;;; (defun %digit-0-or-plusp (digit) (declare (type bignum-element-type digit)) (not (logbitp (1- digit-size) digit))) (declaim (inline %bignum-0-or-plusp)) (defun %bignum-0-or-plusp (bignum len) (declare (type bignum-type bignum) (type bignum-index len)) (%digit-0-or-plusp (%bignum-ref bignum (1- len)))) ;;; %ADD-WITH-CARRY -- Internal. ;;; ;;; This should be in assembler, and should not cons intermediate results. It ;;; returns a 32bit digit and a carry resulting from adding together a, b, and ;;; an incoming carry. ;;; (defun %add-with-carry (a b carry) (declare (type bignum-element-type a b) (type (mod 2) carry)) (%add-with-carry a b carry)) ;;; %SUBTRACT-WITH-BORROW -- Internal. ;;; ;;; This should be in assembler, and should not cons intermediate results. It ;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and ;;; subtracting a possible incoming borrow. ;;; ;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. ;;; (defun %subtract-with-borrow (a b borrow) (declare (type bignum-element-type a b) (type (mod 2) borrow)) (%subtract-with-borrow a b borrow)) ;;; %MULTIPLY -- Internal. ;;; ;;; This multiplies two digit-size (32-bit) numbers, returning a 64-bit result ;;; split into two 32-bit quantities. ;;; (defun %multiply (x y) (declare (type bignum-element-type x y)) (%multiply x y)) ;;; %MULTIPLY-AND-ADD -- Internal. ;;; ;;; This multiplies x-digit and y-digit, producing high and low digits ;;; manifesting the result. Then it adds the low digit, res-digit, and ;;; carry-in-digit. Any carries (note, you still have to add two digits at a ;;; time possibly producing two carries) from adding these three digits get ;;; added to the high digit from the multiply, producing the next carry digit. ;;; Res-digit is optional since two uses of this primitive multiplies a single ;;; digit bignum by a multiple digit bignum, and in this situation there is no ;;; need for a result buffer accumulating partial results which is where the ;;; res-digit comes from. ;;; (defun %multiply-and-add (x-digit y-digit carry-in-digit &optional (res-digit 0)) (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit)) (%multiply-and-add x-digit y-digit carry-in-digit res-digit)) ;;; %LOGNOT -- Internal. ;;; (defun %lognot (digit) (declare (type bignum-element-type digit)) (%lognot digit)) ;;; %LOGAND -- Internal. ;;; %LOGIOR -- Internal. ;;; %LOGXOR -- Internal. ;;; ;;; Do the 32bit unsigned op. ;;; (declaim (inline %logand %logior %logxor)) (defun %logand (a b) (declare (type bignum-element-type a b)) (logand a b)) (defun %logior (a b) (declare (type bignum-element-type a b)) (logior a b)) (defun %logxor (a b) (declare (type bignum-element-type a b)) (logxor a b)) ;;; %FIXNUM-TO-DIGIT -- Internal. ;;; ;;; This takes a fixnum and sets it up as an unsigned 32-bit quantity. In ;;; the new system this will mean shifting it right two bits. ;;; (defun %fixnum-to-digit (x) (declare (fixnum x)) (logand x (1- (ash 1 digit-size)))) #-32x16-divide ;;; %FLOOR -- Internal. ;;; ;;; This takes three digits and returns the FLOOR'ed result of dividing the ;;; first two as a 64-bit integer by the third. ;;; ;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR ;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER ;;; CORRECTLY ALLOCATE REGISTERS. ;;; (defun %floor (a b c) (let ((a a) (b b) (c c)) (declare (type bignum-element-type a b c)) (setq a a b b c c) (%floor a b c))) ;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN -- Internal. ;;; ;;; Convert the digit to a regular integer assuming that the digit is signed. ;;; (defun %fixnum-digit-with-correct-sign (digit) (declare (type bignum-element-type digit)) (if (logbitp (1- digit-size) digit) (logior digit (ash -1 digit-size)) digit)) ;;; %ASHR -- Internal. ;;; ;;; Do an arithmetic shift right of data even though bignum-element-type is ;;; unsigned. ;;; (defun %ashr (data count) (declare (type bignum-element-type data) (type (mod #+amd64 64 #-amd64 32) count)) (%ashr data count)) ;;; %ASHL -- Internal. ;;; ;;; This takes a 32-bit quantity and shifts it to the left, returning a 32-bit ;;; quantity. (defun %ashl (data count) (declare (type bignum-element-type data) (type (mod 32) count)) (%ashl data count)) ;;; %DIGIT-LOGICAL-SHIFT-RIGHT -- Internal ;;; ;;; Do an unsigned (logical) right shift of a digit by Count. ;;; (defun %digit-logical-shift-right (data count) (declare (type bignum-element-type data) (type (mod 32) count)) (%digit-logical-shift-right data count)) ;;; %BIGNUM-SET-LENGTH -- Internal. ;;; ;;; Change the length of bignum to be newlen. Newlen must be the same or ;;; smaller than the old length, and any elements beyond newlen must be zeroed. ;;; (defun %bignum-set-length (bignum newlen) (declare (type bignum-type bignum) (type bignum-index newlen)) (%bignum-set-length bignum newlen)) ;;; %SIGN-DIGIT -- Internal. ;;; ;;; This returns 0 or "-1" depending on whether the bignum is positive. This ;;; is suitable for infinite sign extension to complete additions, ;;; subtractions, negations, etc. This cannot return a -1 represented as ;;; a negative fixnum since it would then have two low zeros. ;;; (declaim (inline %sign-digit)) (defun %sign-digit (bignum len) (declare (type bignum-type bignum) (type bignum-index len)) (%ashr (%bignum-ref bignum (1- len)) (1- digit-size))) ;;; %DIGIT-COMPARE and %DIGIT-GREATER -- Internal. ;;; ;;; These take two 32 bit quantities and compare or contrast them without ;;; wasting time with incorrect type checking. ;;; (declaim (inline %digit-compare %digit-greater)) (defun %digit-compare (x y) (= x y)) ;;; (defun %digit-greater (x y) (> x y)) (declaim (optimize (speed 3) (safety 0)(ext:inhibit-warnings 3))) ;;;; Addition. (defun add-bignums (a b) (declare (type bignum-type a b)) (let ((len-a (%bignum-length a)) (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (multiple-value-bind (a len-a b len-b) (if (> len-a len-b) (values a len-a b len-b) (values b len-b a len-a)) (declare (type bignum-type a b) (type bignum-index len-a len-b)) (let* ((len-res (1+ len-a)) (res (%allocate-bignum len-res)) (carry 0)) (declare (type bignum-index len-res) (type bignum-type res) (type (mod 2) carry)) (dotimes (i len-b) (declare (type bignum-index i)) (multiple-value-bind (v k) (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry) (declare (type bignum-element-type v) (type (mod 2) k)) (setf (%bignum-ref res i) v) (setf carry k))) (if (/= len-a len-b) (finish-add a res carry (%sign-digit b len-b) len-b len-a) (setf (%bignum-ref res len-a) (%add-with-carry (%sign-digit a len-a) (%sign-digit b len-b) carry))) (%normalize-bignum res len-res))))) ;;; FINISH-ADD -- Internal. ;;; ;;; This takes the longer of two bignums and propagates the carry through its ;;; remaining high order digits. ;;; (defun finish-add (a res carry sign-digit-b start end) (declare (type bignum-type a res) (type (mod 2) carry) (type bignum-element-type sign-digit-b) (type bignum-index start end)) (do ((i start (1+ i))) ((= i end) (setf (%bignum-ref res end) (%add-with-carry (%sign-digit a end) sign-digit-b carry))) (declare (type bignum-index i)) (multiple-value-bind (v k) (%add-with-carry (%bignum-ref a i) sign-digit-b carry) (setf (%bignum-ref res i) v) (setf carry k))) (ext:undefined-value)) ;;;; Subtraction. (eval-when (compile eval) ;;; SUBTRACT-BIGNUM-LOOP -- Internal. ;;; ;;; This subtracts b from a plugging result into res. Return-fun is the ;;; function to call that fixes up the result returning any useful values, such ;;; as the result. This macro may evaluate its arguments more than once. ;;; (defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun) (let ((borrow (gensym)) (a-digit (gensym)) (a-sign (gensym)) (b-digit (gensym)) (b-sign (gensym)) (i (gensym)) (v (gensym)) (k (gensym))) `(let* ((,borrow 1) (,a-sign (%sign-digit ,a ,len-a)) (,b-sign (%sign-digit ,b ,len-b))) (declare (type bignum-element-type ,a-sign ,b-sign)) (dotimes (,i ,len-res) (declare (type bignum-index ,i)) (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign)) (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign))) (declare (type bignum-element-type ,a-digit ,b-digit)) (multiple-value-bind (,v ,k) (%subtract-with-borrow ,a-digit ,b-digit ,borrow) (setf (%bignum-ref ,res ,i) ,v) (setf ,borrow ,k)))) (,return-fun ,res ,len-res)))) ) ;EVAL-WHEN (defun subtract-bignum (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) (len-b (%bignum-length b)) (len-res (1+ (max len-a len-b))) (res (%allocate-bignum len-res))) (declare (type bignum-index len-a len-b len-res)) ;Test len-res for bounds? (subtract-bignum-loop a len-a b len-b res len-res %normalize-bignum))) ;;; SUBTRACT-BIGNUM-BUFFERS -- Internal. ;;; ;;; Operations requiring a subtraction without the overhead of intermediate ;;; results, such as GCD, use this. It assumes Result is big enough for the ;;; result. ;;; (defun subtract-bignum-buffers-with-len (a len-a b len-b result len-res) (declare (type bignum-type a b) (type bignum-index len-a len-b)) (subtract-bignum-loop a len-a b len-b result len-res %normalize-bignum-buffer)) (defun subtract-bignum-buffers (a len-a b len-b result) (declare (type bignum-type a b) (type bignum-index len-a len-b)) (subtract-bignum-loop a len-a b len-b result (max len-a len-b) %normalize-bignum-buffer)) ;;;; Multiplication. ;;; ********************************************************************** ;;; ;;; This Karatsuba implementation was written by Raymond Toy and ;;; Douglas T. Crosher and has been placed in the Public domain, and ;;; is provided 'as is'. ;;; ;;; ********************************************************************** ;;; ;;; Karatsuba multiplication. ;;; References: Knuth, Seminumerical Algorithms. ;;; ;;; Based on an implementation by Raymond Toy, whose explanation follows: ;;; ;;; Let U = (b^n)*U1 + U0 and V = (b^n)*V1 + V0 be two positive ;;; integers consisting of b^(2n) base-b digits. Typically, we use ;;; either base 2 digits or base 2^32 digits. ;;; ;;; The product U*V can be written ;;; ;;; U*V = (b^(2n))*U1*V1 + (b^n)(U0*V1 + U1*V0) + U0*V0 ;;; ;;; However, the middle term can be written as ;;; ;;; U0*V1 + U1*V0 = U0*V0 + U1*V1 - (U0 - U1)*(V0 - V1) ;;; ;;; Thus, ;;; ;;; U*V = (b^(2n))*U1+V1 + (b^n)*[U1*V1 + U0*V0 - (U0 - U1)*(V0 - V1)] ;;; U0*V0 ;;; ;;; Note that now we require only three multiplies: U1*V1, U0*V0, and ;;; (U0 - U1)*(V0 - V1). This should speed up multiplication ;;; considerably. ;;; ;;; For implemenation, we only want to work with positive numbers. ;;; Since U0-U1 or V0-V1 may be negative, we need to account for this. ;;; To do so, we compute ;;; ;;; U1*V1 + U0*V0 - Su*Sv*|U0 - U1|*|V0 - V1| ;;; ;;; where Su = sign (U0 - U1) and Sv = sign (V0 - V1). ;;; ;;; Note that some authors use the expression ;;; ;;; U0*V1 + U1*V0 = (U0 + U1)*(V0 + V1) - U0*V0 - U1*V1 ;;; ;;; We don't because if U0 and U1 each contain b^n digits, U0 + U1 can ;;; overflow to b^n + 1 digits. This complicates the multiplication quite a ;;; bit, so we use |U0 - U1|. This is guaranteed not to overflow since U0 and ;;; U1 are both positive with b^n digits. ;;; ;;; karatsuba-internal -- Internal. ;;; ;;; Main routine for Karatsuba multiplication. ;;; By Douglas Crosher. ;;; ;;; The result is placed in the result bignum starting at position RET, and is ;;; of size 2xD words. An extra D words are used during the calculations. ;;; ;;; The calculations are packed into this working space as follows: ;;; ;;; ------------------------------------------------------------------ ;;; | | D/2 | D/2 | D/2 | D/2 | D/2 | D/2 | ;;; |----+---------+---------+---------+---------+---------+---------| ;;; | A. | |u1-u0| | |v1-v0| | x | |u1-u0|*|v1-v0| | ;;; | B. | u0 * v0 | |u1-u0|*|v1-v0| | ;;; | C. | u0 * v0 - S|u1-u0|*|v1-v0| | x | ;;; | D. | u0 * v0 - S|u1-u0|*|v1-v0| | v1 * v0 | ;;; | E. | u0 * v0 - S|u1-u0|*|v1-v0| + v1 * v0 | x | x | ;;; ------------------------------------------------------------------ ;;; ;;; A. Calculate |u1-u0| place the result in the first D/2 words, and ;;; calculate |v1-v0| placing the result the second D/2 words. Then ;;; calculate |u1-u0|*|v1-v0| using the last 3 D/2 words for the result and ;;; subcalculate scratch area. ;;; ;;; B. Calculate the product u0*v0, using the first 3 D/2 words for the result ;;; and subcalculate scratch area. ;;; ;;; C. Sum the results of first two stages into the first 3 D/2 words. ;;; The calculation is (u0*v0) + ((u0*v0) - S|u1-u0|*|v1-v0|) *2^(d/2). ;;; ;;; D. Calculate the product u1*v1, using the last 3 D/2 words for the result ;;; and subcalculate scratch area. ;;; ;;; E. Finally sum in u1*v1 to give the result in the first 4 D/2 words. ;;; ;; This might need some tuning (declaim (fixnum *karatsuba-classical-cutoff*)) (defparameter *karatsuba-classical-cutoff* 10 "When the bignum pieces are smaller than this many words, we use the classical multiplication algorithm instead of recursing all the way down to individual words.") (defun karatsuba-internal (u v ret n d result) (declare (type bignum-index u v ret) (type bignum-index d n) (type bignum-type result) (optimize (speed 3) (safety 0) (debug 0))) (let* ((odd (logand d 1)) (origd d) (d/2- (ash d -1)) (d/2 (+ d/2- odd)) (d (* d/2 2)) (n/2 (ash n -1))) (labels ((bignum-multiply-in-place (u v ret d result cleard) (declare (type bignum-index u v ret) (type bignum-index d) (type bignum-type result) (optimize (speed 3) (safety 0) (debug 0))) ;; Clear out the result area, which might contain garbage for ;; other recursions! (do ((i ret (1+ i)) (end (+ ret (* 2 cleard)))) ((>= i end)) (setf (%bignum-ref result i) 0)) ;; Stolen from bignum.lisp multiply-bignum: a straight forward ;; multiplication via the classical schoolbook algorithm. (dotimes (i d) (declare (type bignum-index i)) (let ((carry-digit 0) (x (%bignum-ref result (+ u i))) (k (+ ret i))) (declare (type bignum-index k) (type bignum-element-type carry-digit x)) (do ((j d (1- j)) (v+j v (1+ v+j))) ((zerop j)) (declare (type bignum-index j v+j)) (multiple-value-bind (big-carry res-digit) (%multiply-and-add x (%bignum-ref result v+j) (%bignum-ref result k) carry-digit) (declare (type bignum-element-type big-carry res-digit)) (setf (%bignum-ref result k) res-digit) (setf carry-digit big-carry) (incf k))) (setf (%bignum-ref result k) carry-digit)))) (abs-diff (n1 x n2 y res result) (declare (type bignum-index n1 n2) (type bignum-index x y res)) (flet ((bigger-p () ;; We guarantee in the caller that n1 is either ;; n2 or (1+ n2) (when (> n1 n2) ;;(assert (= n1 (1+ n2))) (if (zerop (%bignum-ref result (+ x n1 -1))) (progn (setf (%bignum-ref result (+ res n1 -1)) 0) (decf n1)) (return-from bigger-p t))) ;; Return T if X >= Y. (do ((i (1- (+ x n1)) (1- i)) (j (1- (+ y n2)) (1- j))) (()) (declare (type bignum-index i j)) (let ((x-digit (%bignum-ref result i)) (y-digit (%bignum-ref result j))) (when (/= x-digit y-digit) (return-from bigger-p (>= x-digit y-digit)))) ;; Need to test for the exit condition here ;; instead of in the DO headers because when ;; X or Y is 0 and the numbers are equal I ;; or J will be decremented to -1, which ;; isn't of type bignum-index. (when (= i x) (return-from bigger-p t))))) (declare (inline bigger-p)) (let ((sign 1)) (when (not (bigger-p)) (rotatef x y) (rotatef n1 n2) (setf sign -1)) (let ((borrow 1)) (do ((i x (1+ i)) (j y (1+ j)) (k res (1+ k)) (end (+ x n1)) (end2 (+ y n2))) ((>= i end)) (declare (type bignum-index i j k end)) (multiple-value-bind (diff new-borrow) (%subtract-with-borrow (%bignum-ref result i) (if (>= j end2) 0 (%bignum-ref result j)) borrow) (setf (%bignum-ref result k) diff) (setf borrow new-borrow))) sign)))) (propagate-carry (start end carry) (declare (type bignum-type result) (type bignum-index start end) (type (integer -4 4) carry)) (cond ((minusp carry) (multiple-value-bind (sum borrow) (%subtract-with-borrow (%bignum-ref result start) (- carry) 1) (setf (%bignum-ref result start) sum) (do ((i (1+ start) (1+ i))) ((or (>= i end) (= borrow 1)) (- borrow 1)) (declare (type bignum-index i)) (multiple-value-bind (sum next-borrow) (%subtract-with-borrow (%bignum-ref result i) 0 borrow) (setf borrow next-borrow) (setf (%bignum-ref result i) sum))))) (t (multiple-value-bind (sum carry) (%add-with-carry (%bignum-ref result start) carry 0) (setf (%bignum-ref result start) sum) (do ((i (1+ start) (1+ i))) ((or (>= i end) (zerop carry)) carry) (declare (type bignum-index i)) (multiple-value-bind (sum next-carry) (%add-with-carry (%bignum-ref result i) 0 carry) (setf carry next-carry) (setf (%bignum-ref result i) sum))))))) (stageC-add () (let ((carry11 0) (carry12 0) (carry2 0)) (do ((i0 ret (1+ i0)) (i1 (+ ret d/2) (1+ i1)) (i2 (+ ret d) (1+ i2)) (i3 (+ ret n/2) (1+ i3)) (i4 (+ ret n/2 d/2) (1+ i4)) (end (+ ret d/2))) ((>= i0 end)) (declare (type bignum-index i0 i1 i2 i3 i4)) (let ((b (%bignum-ref result i1))) (multiple-value-bind (sum c1) (%add-with-carry b (%bignum-ref result i0) carry11) (multiple-value-bind (sum c2) (%add-with-carry sum (%bignum-ref result i3) carry12) (setf carry11 c1) (setf carry12 c2) (setf (%bignum-ref result i1) sum))) (multiple-value-bind (sum carry) (%add-with-carry b (%bignum-ref result i4) carry2) (setf (%bignum-ref result i2) sum) (setf carry2 carry)))) (+ (propagate-carry (+ ret d) (+ ret n/2) (+ carry11 carry12)) carry2))) (stageC-subtract () (let ((carry11 0) (borrow12 1) (borrow2 1)) (do ((i0 ret (1+ i0)) (i1 (+ ret d/2) (1+ i1)) (i2 (+ ret d) (1+ i2)) (i3 (+ ret n/2) (1+ i3)) (i4 (+ ret n/2 d/2) (1+ i4)) (end (+ ret d/2))) ((>= i0 end)) (declare (type bignum-index i0 i1 i2 i3 i4)) (let ((b (%bignum-ref result i1))) (multiple-value-bind (sum c1) (%add-with-carry b (%bignum-ref result i0) carry11) (multiple-value-bind (sum b2) (%subtract-with-borrow sum (%bignum-ref result i3) borrow12) (setf carry11 c1) (setf borrow12 b2) (setf (%bignum-ref result i1) sum))) (multiple-value-bind (sum borrow) (%subtract-with-borrow b (%bignum-ref result i4) borrow2) (setf (%bignum-ref result i2) sum) (setf borrow2 borrow)))) (+ (propagate-carry (+ ret d) (+ ret n/2) (+ carry11 borrow12 -1)) (- borrow2 1)))) (stageE-add (stageC-carry) ;; Sum the above pieces, result to R0124. (let ((carry1 0) (carry21 0) (carry22 0)) (declare (type (mod 2) carry1 carry21 carry22)) (do ((i0 ret (1+ i0)) (i1 (+ ret d/2) (1+ i1)) (i2 (+ ret d) (1+ i2)) (i3 (+ ret d d/2) (1+ i3)) (i4 (+ ret d d) (1+ i4)) (end (+ ret d/2))) ((>= i0 end)) (declare (type bignum-index i0 i1 i2 i3 i4)) (multiple-value-bind (sum c1) (%add-with-carry (%bignum-ref result i1) (%bignum-ref result i3) carry1) (setf carry1 c1) (setf (%bignum-ref result i1) sum)) (let ((e (%bignum-ref result i4))) (multiple-value-bind (sum c1) (%add-with-carry e (%bignum-ref result i2) carry21) (multiple-value-bind (sum c2) (%add-with-carry sum (%bignum-ref result i3) carry22) (setf carry21 c1) (setf carry22 c2) (setf (%bignum-ref result i2) sum))) (setf (%bignum-ref result i3) e))) (propagate-carry (+ ret d) (+ ret d d) carry1) (propagate-carry (+ ret d d/2) (+ ret d d) (+ carry21 carry22 stageC-carry))))) (cond ((<= d (ext:truly-the fixnum *karatsuba-classical-cutoff*)) (bignum-multiply-in-place u v ret origd result d)) (t (let* ((ret1 (+ ret d/2)) (ret3 (+ ret n/2)) (u-hi (+ u d/2)) (v-hi (+ v d/2)) (diff-sign (* (abs-diff d/2 u d/2- u-hi ret result) (abs-diff d/2 v d/2- v-hi ret1 result)))) (declare (type bignum-index d/2 ret1 ret3 u-hi v-hi) (type (member -1 1) diff-sign)) (do ((i ret3 (1+ i))) ((>= i (+ ret3 d))) (setf (%bignum-ref result i) 0)) (karatsuba-internal ret ret1 ret3 n/2 d/2 result) (do ((i ret (1+ i))) ((>= i ret3)) (setf (%bignum-ref result i) 0)) (karatsuba-internal u v ret n/2 d/2 result) (let ((stagec-carry (if (minusp diff-sign) (stagec-add) (stagec-subtract)))) (setf ret3 (+ ret d d/2)) (karatsuba-internal u-hi v-hi ret3 n/2 d/2- result) (when (/= d/2 d/2-) (setf (%bignum-ref result (+ ret3 (* d/2- 2))) 0) (setf (%bignum-ref result (+ ret3 (* d/2- 2) 1)) 0)) (stageE-add stageC-carry)))))) result)) ;;; karatsuba -- Interface. ;;; ;;; Multiply two bignums using the Karatsuba multiplication technique. ;;; ;;; The arguments are currently copied to the end of the working ;;; result causing some extra consing, and the arguments are both ;;; extended to have the same width implementation rather than ;;; exploiting a small width. ;;; (defun karatsuba (x y) (declare (type bignum-type x y) (optimize (speed 3) (safety 0))) (flet ((power-of-two (n) ;; Compute the smallest power of two greater than or equal ;; to the given number. (declare (type bignum-index n)) (let ((power 1)) (declare (type bignum-index power)) (loop while (< power n) do (setf power (ash power 1))) power))) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x))) (y (if y-plusp y (negate-bignum y))) (negate-res (not (eq x-plusp y-plusp))) (x-words (ceiling (integer-length x) 32)) (y-words (ceiling (integer-length y) 32)) (d (max x-words y-words)) (n (power-of-two d))) (declare (type bignum-index n)) (let ((result (%allocate-bignum (* 5 n)))) ;; Copy X, Y to the end of the result area, so that we can use ;; indices off of the result area for accessing everything. (do ((k 0 (1+ k)) (x-save (* 3 n) (1+ x-save))) ((>= k x-words)) (setf (%bignum-ref result x-save) (%bignum-ref x k))) (do ((k 0 (1+ k)) (save (* 4 n) (1+ save))) ((>= k y-words)) (setf (%bignum-ref result save) (%bignum-ref y k))) ;; Do it. (karatsuba-internal (* 3 n) (* 4 n) 0 (* n 3) (max x-words y-words) result) ;; Convert the result into a bignum. (let ((new-len (1+ (* 2 n))) (n5 (* n 5))) (do ((k (* 2 d) (1+ k))) ((>= k n5)) ;;(assert (< k (%bignum-length result))) (setf (%bignum-ref result k) 0)) (%bignum-set-length result new-len) (when negate-res (negate-bignum-in-place result)) (%normalize-bignum result (1+ (* 2 n)))))))) (defun classical-multiply-bignums (a b) (declare (type bignum-type a b)) (let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a))) (b-plusp (%bignum-0-or-plusp b (%bignum-length b))) (a (if a-plusp a (negate-bignum a))) (b (if b-plusp b (negate-bignum b))) (len-a (%bignum-length a)) (len-b (%bignum-length b)) (len-res (+ len-a len-b)) (res (%allocate-bignum len-res)) (negate-res (not (eq a-plusp b-plusp)))) (declare (type bignum-index len-a len-b len-res)) (dotimes (i len-a) (declare (type bignum-index i)) (let ((carry-digit 0) (x (%bignum-ref a i)) (k i)) (declare (type bignum-index k) (type bignum-element-type carry-digit x)) (dotimes (j len-b) (multiple-value-bind (big-carry res-digit) (%multiply-and-add x (%bignum-ref b j) (%bignum-ref res k) carry-digit) (declare (type bignum-element-type big-carry res-digit)) (setf (%bignum-ref res k) res-digit) (setf carry-digit big-carry) (incf k))) (setf (%bignum-ref res k) carry-digit))) (when negate-res (negate-bignum-in-place res)) (%normalize-bignum res len-res))) (defparameter *min-karatsuba-bits* 512 "Use Karatsuba if the bignums have at least this many bits") (defun multiply-bignums (a b) (declare (type bignum-type a b)) ;; Use either the classical algorithm or the Karatsuba algorithm ;; depending on the size of the numbers. (let* ((len-a (integer-length a)) (len-b (integer-length b)) (min-len (min len-a len-b)) (max-len (max len-a len-b))) ;; If both numbers are short, use the classical algorithm. If the ;; numbers vary greatly in length, use the classical algorithm. ;; Otherwise use the Karatsuba algorithm. (if (or (<= min-len *min-karatsuba-bits*) (>= max-len (* 4 min-len))) (classical-multiply-bignums a b) (karatsuba a b)))) #| ;;;; Test code. (defun karat-time (n size) (declare (fixnum n)) (let ((max-num (ash 1 size)) (true 0) (kar 0)) (time (dotimes (i n) (declare (fixnum i)) (let ((x (random max-num)) (y (random max-num))) (dotimes (j 10) (declare (fixnum j)) (setf true (classical-multiply-bignums x y)))))) (time (dotimes (i n) (declare (fixnum i)) (let ((x (random max-num)) (y (random max-num))) (dotimes (j 10) (declare (fixnum j)) (setf kar (multiply-bignums x y)))))) (let ((bad (/= kar true))) (format t "DIFF~%") #+nil (when bad (format t "(- (* ~X ~X) ~X)~%" x y kar) (format t "~X~%~X~%" (* x y) kar))) (values))) (defun karat-time (n size) (declare (fixnum n)) (let* ((max-num (ash 1 size)) (true 0) (kar 0) (x (random max-num)) (y (random max-num))) (ext:gc) (format t "~D bits x ~D bits~%" (integer-length x) (integer-length y)) (time (dotimes (i n) (declare (fixnum i)) (dotimes (j 10) (declare (fixnum j)) (setf true (classical-multiply-bignums x y))))) (ext:gc) (time (dotimes (i n) (declare (fixnum i)) (dotimes (j 10) (declare (fixnum j)) (setf kar (multiply-bignums x y))))) (format t "~X~%~X" x y) (let ((bad (/= kar true))) (when bad (format t "DIFF~%") (format t "(- (* ~X ~X) ~X)~%" x y kar) (format t "~X~%~X~%" (* x y) kar))) (values))) (defun karat-time-2 (n size) (declare (fixnum n)) (let* ((max-num (ash 1 size)) (max-half (ash 1 (floor size 2))) (true 0) (kar 0) (x (random max-num)) (y (random max-half))) (ext:gc) (time (dotimes (i n) (declare (fixnum i)) (dotimes (j 10) (declare (fixnum j)) (setf true (classical-multiply-bignums x y))))) (ext:gc) (time (dotimes (i n) (declare (fixnum i)) (dotimes (j 10) (declare (fixnum j)) (setf kar (multiply-bignums x y))))) (format t "~X~%~X" x y) (let ((bad (/= kar true))) (when bad (format t "DIFF~%") (format t "(- (* ~X ~X) ~X)~%" x y kar) (format t "~X~%~X~%" (* x y) kar))) (values))) (defun karat-test (n size) (declare (fixnum n)) (dotimes (k n) (let* ((max-num (ash 1 size)) (x (random max-num)) (y (random max-num)) (true 0) (kar 0)) (declare (fixnum k)) (setf true (classical-multiply-bignums x y)) (setf kar (multiply-bignums x y)) (let ((bad (/= kar true))) (when bad (format t "(- (* ~X ~X) ~X)~%" x y kar) (format t "~X~%~X~%" (* x y) kar))))) (values)) |# (defun multiply-bignum-and-fixnum (bignum fixnum) (declare (type bignum-type bignum) (type fixnum fixnum)) (let* ((bignum-plus-p (%bignum-0-or-plusp bignum (%bignum-length bignum))) (fixnum-plus-p (not (minusp fixnum))) (bignum (if bignum-plus-p bignum (negate-bignum bignum))) (bignum-len (%bignum-length bignum)) (fixnum (if fixnum-plus-p fixnum (- fixnum))) (result (%allocate-bignum (1+ bignum-len))) (carry-digit 0)) (declare (type bignum-type bignum result) (type bignum-index bignum-len) (type bignum-element-type fixnum carry-digit)) (dotimes (index bignum-len) (declare (type bignum-index index)) (multiple-value-bind (next-digit low) (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit) (declare (type bignum-element-type next-digit low)) (setf carry-digit next-digit) (setf (%bignum-ref result index) low))) (setf (%bignum-ref result bignum-len) carry-digit) (unless (eq bignum-plus-p fixnum-plus-p) (negate-bignum-in-place result)) (%normalize-bignum result (1+ bignum-len)))) (defun multiply-fixnums (a b) (declare (fixnum a b)) (let* ((a-minusp (minusp a)) (b-minusp (minusp b))) (multiple-value-bind (high low) (%multiply (if a-minusp (- a) a) (if b-minusp (- b) b)) (declare (type bignum-element-type high low)) (if (and (zerop high) (%digit-0-or-plusp low)) (let ((low (ext:truly-the (unsigned-byte 31) (%fixnum-digit-with-correct-sign low)))) (if (eq a-minusp b-minusp) low (- low))) (let ((res (%allocate-bignum 2))) (%bignum-set res 0 low) (%bignum-set res 1 high) (unless (eq a-minusp b-minusp) (negate-bignum-in-place res)) (%normalize-bignum res 2)))))) ;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS. (eval-when (compile eval) ;;; BIGNUM-REPLACE -- Internal. ;;; (defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 from-end) (ext:once-only ((n-dest dest) (n-src src)) (let ((n-start1 (gensym)) (n-end1 (gensym)) (n-start2 (gensym)) (n-end2 (gensym)) (i1 (gensym)) (i2 (gensym)) (end1 (or end1 `(%bignum-length ,n-dest))) (end2 (or end2 `(%bignum-length ,n-src)))) (if from-end `(let ((,n-start1 ,start1) (,n-start2 ,start2)) (do ((,i1 (1- ,end1) (1- ,i1)) (,i2 (1- ,end2) (1- ,i2))) ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) (declare (fixnum ,i1 ,i2)) (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))) `(let ((,n-end1 ,end1) (,n-end2 ,end2)) (do ((,i1 ,start1 (1+ ,i1)) (,i2 ,start2 (1+ ,i2))) ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) (declare (type bignum-index ,i1 ,i2)) (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))))))) ;;; WITH-BIGNUM-BUFFERS -- Internal. ;;; ;;; Could do freelisting someday. ;;; (defmacro with-bignum-buffers (specs &body body) "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" (ext:collect ((binds) (inits)) (dolist (spec specs) (let ((name (first spec)) (size (second spec))) (binds `(,name (%allocate-bignum ,size))) (let ((init (third spec))) (when init (inits `(bignum-replace ,name ,init)))))) `(let* ,(binds) ,@(inits) ,@body))) ) ;EVAL-WHEN ;;;; GCD. ;;; MAKE-SMALL-BIGNUM -- Public. ;;; ;;; Allocate a single word bignum that holds fixnum. This is useful when ;;; we are trying to mix fixnum and bignum operands. ;;; (declaim (inline make-small-bignum)) (defun make-small-bignum (fixnum) (let ((res (%allocate-bignum 1))) (setf (%bignum-ref res 0) (%fixnum-to-digit fixnum)) res)) (eval-when (:compile-toplevel :load-toplevel :execute) ;; The asserts in the GCD implementation are way too expensive to ;; check in normal use, and are disabled here. (defmacro gcd-assert (&rest args) (if nil `(assert ,@args))) ;; We'll be doing a lot of modular arithmetic. (defmacro M (form) `(logand all-ones-digit ,form)) ) ;; When the larger number is less than this many bignum digits long, revert ;; to old algorithm. (defparameter *accelerated-gcd-cutoff* 3) ;;; Alternate between k-ary reduction with the help of ;;; REDUCED-RATIO-MOD and digit modulus reduction via DMOD. Once the ;;; arguments get small enough, drop through to BIGNUM-MOD-GCD (since ;;; k-ary reduction can introduce spurious factors, which need to be ;;; filtered out). Reference: Kenneth Weber, "The accelerated integer ;;; GCD algorithm", ACM Transactions on Mathematical Software, volume ;;; 21, number 1, March 1995, epp. 111-122. (defun bignum-gcd (u0 v0) (declare (type bignum-type u0 v0)) (let* ((u1 (if (%bignum-0-or-plusp u0 (%bignum-length u0)) u0 (negate-bignum u0 nil))) (v1 (if (%bignum-0-or-plusp v0 (%bignum-length v0)) v0 (negate-bignum v0 nil)))) (if (zerop v1) (return-from bignum-gcd u1)) (when (> u1 v1) (rotatef u1 v1)) (let ((n (mod v1 u1))) (setf v1 (if (fixnump n) (make-small-bignum n) n))) (if (and (= 1 (%bignum-length v1)) (zerop (%bignum-ref v1 0))) (return-from bignum-gcd (%normalize-bignum u1 (%bignum-length u1)))) (let* ((buffer-len (+ 2 (%bignum-length u1))) (u (%allocate-bignum buffer-len)) (u-len (%bignum-length u1)) (v (%allocate-bignum buffer-len)) (v-len (%bignum-length v1)) (tmp1 (%allocate-bignum buffer-len)) (tmp1-len 0) (tmp2 (%allocate-bignum buffer-len)) (tmp2-len 0) (factors-of-two (bignum-factors-of-two u1 (%bignum-length u1) v1 (%bignum-length v1)))) (declare (type (or null bignum-index) buffer-len u-len v-len tmp1-len tmp2-len)) (bignum-replace u u1) (bignum-replace v v1) (setf u-len (make-gcd-bignum-odd u (bignum-buffer-ashift-right u u-len factors-of-two))) (setf v-len (make-gcd-bignum-odd v (bignum-buffer-ashift-right v v-len factors-of-two))) (loop until (or (< u-len *accelerated-gcd-cutoff*) (not v-len) (zerop v-len) (and (= 1 v-len) (zerop (%bignum-ref v 0)))) do (gcd-assert (= buffer-len (%bignum-length u) (%bignum-length v) (%bignum-length tmp1) (%bignum-length tmp2))) (if (> (bignum-buffer-integer-length u u-len) (+ #.(truncate vm:word-bits 4) (bignum-buffer-integer-length v v-len))) (setf u-len (dmod u u-len v v-len tmp1)) (multiple-value-bind (n d) (reduced-ratio-mod u v) (setf tmp1-len (multiply-bignum-buffer-and-smallnum-to-buffer v v-len n tmp1)) (setf tmp2-len (multiply-bignum-buffer-and-smallnum-to-buffer u u-len d tmp2)) (gcd-assert (= (copy-bignum tmp2 tmp2-len) (* (copy-bignum u u-len) d))) (gcd-assert (= (copy-bignum tmp1 tmp1-len) (* (copy-bignum v v-len) n))) (setf u-len (subtract-bignum-buffers-with-len tmp1 tmp1-len tmp2 tmp2-len u (1+ (max tmp1-len tmp2-len)))) (gcd-assert (or (zerop (- (copy-bignum tmp1 tmp1-len) (copy-bignum tmp2 tmp2-len))) (= (copy-bignum u u-len) (- (copy-bignum tmp1 tmp1-len) (copy-bignum tmp2 tmp2-len))))) (bignum-abs-buffer u u-len) (gcd-assert (zerop (M u))))) (setf u-len (make-gcd-bignum-odd u u-len)) (rotatef u v) (rotatef u-len v-len)) (setf u (copy-bignum u u-len)) (bignum-abs-buffer u u-len) (let ((n (bignum-mod-gcd v1 u))) (ash (bignum-mod-gcd u1 (if (fixnump n) (make-small-bignum n) n)) factors-of-two))))) (defun bignum-mod-gcd (a b) (declare (type bignum-type a b)) (when (< a b) (rotatef a b)) ;; While the length difference of A and B is sufficiently large, ;; reduce using MOD (slowish, but it should equalize the sizes of ;; A and B pretty quickly). After that, use the binary GCD ;; algorithm to handle the rest. (loop until (and (= (%bignum-length b) 1) (zerop (%bignum-ref b 0))) do (when (<= (%bignum-length a) (1+ (%bignum-length b))) (return-from bignum-mod-gcd (bignum-binary-gcd a b))) (let ((rem (mod a b))) (if (fixnump rem) (setf a (make-small-bignum rem)) (setf a rem)) (rotatef a b))) (if (= (%bignum-length a) 1) (%normalize-bignum a 1) a)) (defun bignum-binary-gcd (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (with-bignum-buffers ((a-buffer len-a a) (b-buffer len-b b) (res-buffer (max len-a len-b))) (let* ((factors-of-two (bignum-factors-of-two a-buffer len-a b-buffer len-b)) (len-a (make-gcd-bignum-odd a-buffer (bignum-buffer-ashift-right a-buffer len-a factors-of-two))) (len-b (make-gcd-bignum-odd b-buffer (bignum-buffer-ashift-right b-buffer len-b factors-of-two)))) (declare (type bignum-index len-a len-b)) (let ((x a-buffer) (len-x len-a) (y b-buffer) (len-y len-b) (z res-buffer)) (loop (multiple-value-bind (u v len-v r len-r) (bignum-gcd-order-and-subtract x len-x y len-y z) (declare (type bignum-index len-v len-r)) (when (and (= len-r 1) (zerop (%bignum-ref r 0))) (if (zerop factors-of-two) (let ((ret (%allocate-bignum len-v))) (dotimes (i len-v) (setf (%bignum-ref ret i) (%bignum-ref v i))) (return (%normalize-bignum ret len-v))) (return (bignum-ashift-left v factors-of-two len-v)))) (setf x v len-x len-v) (setf y r len-y (make-gcd-bignum-odd r len-r)) (setf z u)))))))) (defun bignum-gcd-order-and-subtract (a len-a b len-b res) (declare (type bignum-index len-a len-b) (type bignum-type a b)) (cond ((= len-a len-b) (do ((i (1- len-a) (1- i))) ((= i -1) (setf (%bignum-ref res 0) 0) (values a b len-b res 1)) (let ((a-digit (%bignum-ref a i)) (b-digit (%bignum-ref b i))) (cond ((%digit-compare a-digit b-digit)) ((%digit-greater a-digit b-digit) (return (values a b len-b res (subtract-bignum-buffers a len-a b len-b res)))) (t (return (values b a len-a res (subtract-bignum-buffers b len-b a len-a res)))))))) ((> len-a len-b) (values a b len-b res (subtract-bignum-buffers a len-a b len-b res))) (t (values b a len-a res (subtract-bignum-buffers b len-b a len-a res))))) (defun make-gcd-bignum-odd (a len-a) (declare (type bignum-type a) (type bignum-index len-a)) (dotimes (index len-a) (declare (type bignum-index index)) (do ((digit (%bignum-ref a index) (%ashr digit 1)) (increment 0 (1+ increment))) ((zerop digit)) (declare (type (mod 32) increment)) (when (oddp digit) (return-from make-gcd-bignum-odd (bignum-buffer-ashift-right a len-a (+ (* index digit-size) increment))))))) (defun bignum-factors-of-two (a len-a b len-b) (declare (type bignum-index len-a len-b) (type bignum-type a)) (do ((i 0 (1+ i)) (end (min len-a len-b))) ((= i end) (error (intl:gettext "Unexpected zero bignums?"))) (declare (type bignum-index i end)) (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i)))) (unless (zerop or-digits) (return (do ((j 0 (1+ j)) (or-digits or-digits (%ashr or-digits 1))) ((oddp or-digits) (+ (* i digit-size) j)) (declare (type (mod 32) j)))))))) ;;; Multiply a bignum buffer with a fixnum or a digit, storing the ;;; result in another bignum buffer, and without using any ;;; temporaries. Inlined to avoid boxing smallnum if it's actually a ;;; digit. Needed by GCD, should possibly OAOO with ;;; MULTIPLY-BIGNUM-AND-FIXNUM. (declaim (inline multiply-bignum-buffer-and-smallnum-to-buffer)) (defun multiply-bignum-buffer-and-smallnum-to-buffer (bignum bignum-len smallnum res) (declare (type bignum-type bignum)) (let* ((bignum-plus-p (%bignum-0-or-plusp bignum bignum-len)) (smallnum-plus-p (not (minusp smallnum))) (smallnum (if smallnum-plus-p smallnum (- smallnum))) (carry-digit 0)) (declare (type bignum-type bignum res) (type bignum-index bignum-len) (type bignum-element-type smallnum carry-digit)) (unless bignum-plus-p (negate-bignum-buffer-in-place bignum bignum-len)) (dotimes (index bignum-len) (declare (type bignum-index index)) (multiple-value-bind (next-digit low) (%multiply-and-add (%bignum-ref bignum index) smallnum carry-digit) (declare (type bignum-element-type next-digit low)) (setf carry-digit next-digit) (setf (%bignum-ref res index) low))) (setf (%bignum-ref res bignum-len) carry-digit) (unless bignum-plus-p (negate-bignum-buffer-in-place bignum bignum-len)) (let ((res-len (%normalize-bignum-buffer res (1+ bignum-len)))) (unless (eq bignum-plus-p smallnum-plus-p) (negate-bignum-buffer-in-place res res-len)) res-len))) ;;; Given U and V, return U / V mod 2^32. Implements the algorithm in the ;;; paper, but uses some clever bit-twiddling nicked from Nickle to do it. (declaim (inline bmod)) (defun bmod (u v) (let ((ud (%bignum-ref u 0)) (vd (%bignum-ref v 0)) (umask 0) (imask 1) (m 0)) (declare (type (unsigned-byte #.vm:word-bits) ud vd umask imask m)) (dotimes (i digit-size) (setf umask (logior umask imask)) (unless (zerop (logand ud umask)) (setf ud (M (- ud vd))) (setf m (M (logior m imask)))) (setf imask (M (%ashl imask 1))) (setf vd (M (%ashl vd 1)))) m)) (defun dmod (u u-len v v-len tmp1) (loop while (> (bignum-buffer-integer-length u u-len) (+ (bignum-buffer-integer-length v v-len) digit-size)) do (unless (zerop (%bignum-ref u 0)) (let* ((bmod (bmod u v)) (tmp1-len (multiply-bignum-buffer-and-smallnum-to-buffer v v-len bmod tmp1))) (setf u-len (subtract-bignum-buffers u u-len tmp1 tmp1-len u)) (bignum-abs-buffer u u-len))) (gcd-assert (zerop (%bignum-ref u 0))) (setf u-len (bignum-buffer-ashift-right u u-len digit-size))) (let* ((d (+ 1 (- (bignum-buffer-integer-length u u-len) (bignum-buffer-integer-length v v-len)))) (n (1- (ash 1 d)))) (declare (type (unsigned-byte #.(integer-length #.vm:word-bits)) d) (type (unsigned-byte #.vm:word-bits) n)) (gcd-assert (>= d 0)) (unless (zerop (logand (%bignum-ref u 0) n)) (let ((tmp1-len (multiply-bignum-buffer-and-smallnum-to-buffer v v-len (logand n (bmod u v)) tmp1))) (setf u-len (subtract-bignum-buffers u u-len tmp1 tmp1-len u)) (bignum-abs-buffer u u-len))) u-len)) (defconstant lower-ones-digit (1- (ash 1 (truncate vm:word-bits 2)))) ;;; Find D and N such that (LOGAND ALL-ONES-DIGIT (- (* D X) (* N Y))) is 0, ;;; (< 0 N LOWER-ONES-DIGIT) and (< 0 (ABS D) LOWER-ONES-DIGIT). (defun reduced-ratio-mod (x y) (let* ((c (bmod x y)) (n1 c) (d1 1) (n2 (M (- n1)) #+nil(M (1+ (M (lognot n1))))) (d2 (M -1))) (declare (type (unsigned-byte #.vm:word-bits) n1 d1 n2 d2)) (loop while (> n2 (expt 2 (truncate digit-size 2))) do (loop for i of-type (signed-byte 5) downfrom (- (integer-length n1) (integer-length n2)) while (>= n1 n2) do (let ((i i)) (declare (type (mod #.vm:word-bits) i)) (when (>= n1 (M (%ashl n2 i))) (psetf n1 (M (- n1 (%ashl n2 i))) d1 (M (- d1 (%ashl d2 i))))))) (psetf n1 n2 d1 d2 n2 n1 d2 d1)) (values n2 (if (>= d2 (expt 2 (1- digit-size))) (lognot (logand most-positive-fixnum (lognot d2))) (logand lower-ones-digit d2))))) (defun copy-bignum (a &optional (len (%bignum-length a))) (let ((b (%allocate-bignum len))) (bignum-replace b a) (%bignum-set-length b len) b)) ;;;; Negation (eval-when (compile eval) ;;; BIGNUM-NEGATE-LOOP -- Internal. ;;; ;;; This negates bignum-len digits of bignum, storing the resulting digits into ;;; result (possibly EQ to bignum) and returning whatever end-carry there is. ;;; (defmacro bignum-negate-loop (bignum bignum-len &optional (result nil resultp)) (let ((carry (gensym)) (end (gensym)) (value (gensym)) (last (gensym))) `(let* (,@(if (not resultp) `(,last)) (,carry (multiple-value-bind (,value ,carry) (%add-with-carry (%lognot (%bignum-ref ,bignum 0)) 1 0) ,(if resultp `(setf (%bignum-ref ,result 0) ,value) `(setf ,last ,value)) ,carry)) (i 1) (,end ,bignum-len)) (declare (type bit ,carry) (type bignum-index i ,end)) (loop (when (= i ,end) (return)) (multiple-value-bind (,value temp) (%add-with-carry (%lognot (%bignum-ref ,bignum i)) 0 ,carry) ,(if resultp `(setf (%bignum-ref ,result i) ,value) `(setf ,last ,value)) (setf ,carry temp)) (incf i)) ,(if resultp carry `(values ,carry ,last))))) ) ;EVAL-WHEN ;;; NEGATE-BIGNUM -- Public. ;;; ;;; Fully-normalize is an internal optional. It causes this to always return ;;; a bignum, without any extraneous digits, and it never returns a fixnum. ;;; (defun negate-bignum (x &optional (fully-normalize t)) (declare (type bignum-type x)) (let* ((len-x (%bignum-length x)) (len-res (1+ len-x)) (res (%allocate-bignum len-res))) (declare (type bignum-index len-x len-res)) ;Test len-res for range? (let ((carry (bignum-negate-loop x len-x res))) (setf (%bignum-ref res len-x) (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry))) (if fully-normalize (%normalize-bignum res len-res) (%mostly-normalize-bignum res len-res)))) ;;; NEGATE-BIGNUM-IN-PLACE -- Internal. ;;; ;;; This assumes bignum is positive; that is, the result of negating it will ;;; stay in the provided allocated bignum. ;;; (defun negate-bignum-buffer-in-place (bignum bignum-len) (bignum-negate-loop bignum bignum-len bignum) bignum) (defun negate-bignum-in-place (bignum) (declare (inline negate-bignum-buffer-in-place)) (negate-bignum-buffer-in-place bignum (%bignum-length bignum))) (defun bignum-abs-buffer (bignum len) (unless (%bignum-0-or-plusp bignum len) (negate-bignum-buffer-in-place bignum len))) ;;;; Shifting. (defconstant all-ones-digit #xFFFFFFFF) (eval-when (compile eval) ;;; SHIFT-RIGHT-UNALIGNED -- Internal. ;;; ;;; This macro is used by BIGNUM-ASHIFT-RIGHT, BIGNUM-BUFFER-ASHIFT-RIGHT, and ;;; BIGNUM-LDB-BIGNUM-RES. They supply a termination form that references ;;; locals established by this form. Source is the source bignum. Start-digit ;;; is the first digit in source from which we pull bits. Start-pos is the ;;; first bit we want. Res-len-form is the form that computes the length of ;;; the resulting bignum. Termination is a DO termination form with a test and ;;; body. When result is supplied, it is the variable to which this binds a ;;; newly allocated bignum. ;;; ;;; Given start-pos (1-31 inclusive) of shift, we form the j'th resulting ;;; digit from high bits of the i'th source digit and the start-pos number of ;;; bits from the i+1'th source digit. ;;; (defmacro shift-right-unaligned (source start-digit start-pos res-len-form termination &optional result) `(let* ((high-bits-in-first-digit (- digit-size ,start-pos)) (res-len ,res-len-form) (res-len-1 (1- res-len)) ,@(if result `((,result (%allocate-bignum res-len))))) (declare (type bignum-index res-len res-len-1)) (do ((i ,start-digit i+1) (i+1 (1+ ,start-digit) (1+ i+1)) (j 0 (1+ j))) ,termination (declare (type bignum-index i i+1 j)) (setf (%bignum-ref ,(if result result source) j) (%logior (%digit-logical-shift-right (%bignum-ref ,source i) ,start-pos) (%ashl (%bignum-ref ,source i+1) high-bits-in-first-digit)))))) ) ;EVAL-WHEN ;;; BIGNUM-ASHIFT-RIGHT -- Public. ;;; ;;; First compute the number of whole digits to shift, shifting them by ;;; skipping them when we start to pick up bits, and the number of bits to ;;; shift the remaining digits into place. If the number of digits is greater ;;; than the length of the bignum, then the result is either 0 or -1. If we ;;; shift on a digit boundary (that is, n-bits is zero), then we just copy ;;; digits. The last branch handles the general case which uses a macro that a ;;; couple of other routines use. The fifth argument to the macro references ;;; locals established by the macro. ;;; (defun bignum-ashift-right (bignum x) (declare (type bignum-type bignum) (type unsigned-byte x)) (let ((bignum-len (%bignum-length bignum))) (declare (type bignum-index bignum-len)) (multiple-value-bind (digits n-bits) (truncate x digit-size) (declare (type bignum-index digits)) (cond ((>= digits bignum-len) (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) ((zerop n-bits) (bignum-ashift-right-digits bignum digits)) (t (shift-right-unaligned bignum digits n-bits (- bignum-len digits) ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref bignum i) n-bits)) (%normalize-bignum res res-len)) res)))))) ;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. ;;; (defun bignum-ashift-right-digits (bignum digits) (declare (type bignum-type bignum) (type bignum-index digits)) (let* ((res-len (- (%bignum-length bignum) digits)) (res (%allocate-bignum res-len))) (declare (type bignum-index res-len) (type bignum-type res)) (bignum-replace res bignum :start2 digits) (%normalize-bignum res res-len))) ;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. ;;; ;;; GCD uses this for an in-place shifting operation. This is different enough ;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a ;;; macro, but they share the basic algorithm. This routine foregoes a first ;;; test for digits being greater than or equal to bignum-len since that will ;;; never happen for its uses in GCD. We did fold the last branch into a macro ;;; since it was duplicated a few times, and the fifth argument to it ;;; references locals established by the macro. ;;; (defun bignum-buffer-ashift-right (bignum bignum-len x) (declare (type bignum-index bignum-len) (fixnum x)) (multiple-value-bind (digits n-bits) (truncate x digit-size) (declare (type bignum-index digits)) (cond ((zerop n-bits) (let ((new-end (- bignum-len digits))) (bignum-replace bignum bignum :end1 new-end :start2 digits :end2 bignum-len) (%normalize-bignum-buffer bignum new-end))) (t (shift-right-unaligned bignum digits n-bits (- bignum-len digits) ((= j res-len-1) (setf (%bignum-ref bignum j) (%ashr (%bignum-ref bignum i) n-bits)) (%normalize-bignum-buffer bignum res-len))))))) ;;; BIGNUM-ASHIFT-LEFT -- Public. ;;; ;;; This handles shifting a bignum buffer to provide fresh bignum data for some ;;; internal routines. We know bignum is safe when called with bignum-len. ;;; First we compute the number of whole digits to shift, shifting them ;;; starting to store farther along the result bignum. If we shift on a digit ;;; boundary (that is, n-bits is zero), then we just copy digits. The last ;;; branch handles the general case. ;;; (defun bignum-ashift-left (bignum x &optional bignum-len) (declare (type bignum-type bignum) (fixnum x) (type (or null bignum-index) bignum-len)) (multiple-value-bind (digits n-bits) (truncate x digit-size) (let* ((bignum-len (or bignum-len (%bignum-length bignum))) (res-len (+ digits bignum-len 1))) (when (> res-len maximum-bignum-length) (error (intl:gettext "Can't represent result of left shift."))) (if (zerop n-bits) (bignum-ashift-left-digits bignum bignum-len digits) (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) ;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. ;;; (defun bignum-ashift-left-digits (bignum bignum-len digits) (declare (type bignum-index bignum-len digits)) (let* ((res-len (+ bignum-len digits)) (res (%allocate-bignum res-len))) (declare (type bignum-index res-len)) (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len :from-end t) res)) ;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. ;;; ;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. ;;; When res comes in non-nil this foregoes allocating a result, and it ;;; normalizes the buffer instead of the would-be allocated result. ;;; ;;; We start storing into one digit higher than digits, storing a whole result ;;; digit from parts of two contiguous digits from bignum. When the loop ;;; finishes, we store the remaining bits from bignum's first digit in the ;;; first non-zero result digit, digits. We also grab some left over high ;;; bits from the last digit of bignum. ;;; (defun bignum-ashift-left-unaligned (bignum digits n-bits res-len &optional (res nil resp)) (declare (type bignum-index digits res-len) (type (mod #.digit-size) n-bits)) (let* ((remaining-bits (- digit-size n-bits)) (res-len-1 (1- res-len)) (res (or res (%allocate-bignum res-len)))) (declare (type bignum-index res-len res-len-1)) (do ((i 0 i+1) (i+1 1 (1+ i+1)) (j (1+ digits) (1+ j))) ((= j res-len-1) (setf (%bignum-ref res digits) (%ashl (%bignum-ref bignum 0) n-bits)) (setf (%bignum-ref res j) (%ashr (%bignum-ref bignum i) remaining-bits)) (if resp (%normalize-bignum-buffer res res-len) (%normalize-bignum res res-len))) (declare (type bignum-index i i+1 j)) (setf (%bignum-ref res j) (%logior (%digit-logical-shift-right (%bignum-ref bignum i) remaining-bits) (%ashl (%bignum-ref bignum i+1) n-bits)))))) ;;;; Relational operators. ;;; BIGNUM-PLUS-P -- Public. ;;; ;;; Return T iff bignum is positive. ;;; (defun bignum-plus-p (bignum) (declare (type bignum-type bignum)) (%bignum-0-or-plusp bignum (%bignum-length bignum))) ;;; BIGNUM-COMPARE -- Public. ;;; ;;; This compares two bignums returning -1, 0, or 1, depending on whether a ;;; is less than, equal to, or greater than b. ;;; (defun bignum-compare (a b) (declare (type bignum-type a b) (values (integer -1 1))) (let* ((len-a (%bignum-length a)) (len-b (%bignum-length b)) (a-plusp (%bignum-0-or-plusp a len-a)) (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((not (eq a-plusp b-plusp)) (if a-plusp 1 -1)) ((= len-a len-b) (do ((i (1- len-a) (1- i))) (()) (declare (type bignum-index i)) (let ((a-digit (%bignum-ref a i)) (b-digit (%bignum-ref b i))) (declare (type bignum-element-type a-digit b-digit)) (when (%digit-greater a-digit b-digit) (return 1)) (when (%digit-greater b-digit a-digit) (return -1))) (when (zerop i) (return 0)))) ((> len-a len-b) (if a-plusp 1 -1)) (t (if a-plusp -1 1))))) ;;;; Float conversion. ;;; xxx-FLOAT-FROM-BITS -- Internal ;;; ;;; Make a single or double float with the specified significand, exponent ;;; and sign. ;;; (defun single-float-from-bits (bits exp plusp) (declare (fixnum exp)) (declare (optimize (ext:inhibit-warnings 3))) (let ((res (dpb exp vm:single-float-exponent-byte (logandc2 (ext:truly-the (unsigned-byte 31) (%bignum-ref bits 1)) vm:single-float-hidden-bit)))) (make-single-float (if plusp res (logior res (ash -1 vm:float-sign-shift)))))) ;;; (defun double-float-from-bits (bits exp plusp) (declare (fixnum exp)) (declare (optimize (ext:inhibit-warnings 3))) (let ((hi (dpb exp vm:double-float-exponent-byte (logandc2 (ext:truly-the (unsigned-byte 31) (%bignum-ref bits 2)) vm:double-float-hidden-bit)))) (make-double-float (if plusp hi (logior hi (ash -1 vm:float-sign-shift))) (%bignum-ref bits 1)))) ;;; #+(and long-float x86) (defun long-float-from-bits (bits exp plusp) (declare (fixnum exp)) (declare (optimize (ext:inhibit-warnings 3))) (make-long-float (if plusp exp (logior exp (ash 1 15))) (%bignum-ref bits 2) (%bignum-ref bits 1))) ;;; #+nil (defun bignum-float-digits (format bignum) ;; For float formats other than double-double-float, we can just use ;; FLOAT-FORMAT-DIGITS. For double-double-float, we need to be more ;; careful. This is needed because double-double-floats can ;; actually have more 106 bits. Consider two bignums, x and y, both ;; 53 bits long. Let z = x*2^n + y, where n > 53. This bignum can ;; be presented as a double-double-float by converting x and y to ;; double-floats and combining them appropriately to make a ;; double-double-float. This also helps with read/write consistency ;; for double-double-floats. (if (not (eq format 'double-double-float)) (float-format-digits format) (let ((len (integer-length bignum)) (default-length (float-format-digits 'double-double-float))) (cond ((> len default-length) ;; Look for the pattern where ;; are the first 53 bits, is sequence of ;; zero bits, and is the next 53 bits. The desired ;; length is then 2*53 + the number of zeroes. (let* ((part (ldb (byte (- len 53) 0) bignum)) (part-len (integer-length part))) ;; PART is the bignum with the 53 MSB removed. #+nil (progn (format t "bignum = ~VB~%" len bignum) (format t "part = ~VB~%" len part) (format t "len = ~A~%" len) (format t "part-l = ~A~%" part-len)) (+ 106 (- len 53 part-len)))) (t default-length))))) ;;; BIGNUM-TO-FLOAT -- Interface ;;; ;;; Convert Bignum to a float in the specified Format, rounding to the best ;;; approximation. ;;; (defun bignum-to-float-float (bignum format) (let* ((plusp (bignum-plus-p bignum)) (x (if plusp bignum (negate-bignum bignum))) (len (bignum-integer-length x)) (digits (float-format-digits format)) (keep (+ digits digit-size)) (shift (- keep len)) (shifted (if (minusp shift) (bignum-ashift-right x (- shift)) (bignum-ashift-left x shift))) (low (%bignum-ref shifted 0)) (round-bit (ash 1 (1- digit-size)))) (declare (type bignum-index len digits keep) (fixnum shift)) (labels ((round-up () (let ((rounded (add-bignums shifted round-bit))) (if (> (integer-length rounded) keep) (float-from-bits (bignum-ashift-right rounded 1) (1+ len)) (float-from-bits rounded len)))) (float-from-bits (bits len) (declare (type bignum-index len)) (ecase format (single-float (single-float-from-bits bits (check-exponent len vm:single-float-bias vm:single-float-normal-exponent-max) plusp)) (double-float (double-float-from-bits bits (check-exponent len vm:double-float-bias vm:double-float-normal-exponent-max) plusp)) #+long-float (long-float (long-float-from-bits bits (check-exponent len vm:long-float-bias vm:long-float-normal-exponent-max) plusp)))) (check-exponent (exp bias max) (declare (type bignum-index len)) (let ((exp (+ exp bias))) (when (> exp max) (error 'simple-type-error :datum x :format-control (intl:gettext "Too large to be represented as a ~S:~% ~S") :format-arguments (list format x) :expected-type format)) exp))) (cond ;; ;; Round down if round bit is 0. ((zerop (logand round-bit low)) (float-from-bits shifted len)) ;; ;; If only round bit is set, then round to even. ((and (= low round-bit) (dotimes (i (- (%bignum-length x) (ceiling keep digit-size)) t) (unless (zerop (%bignum-ref x i)) (return nil)))) (let ((next (%bignum-ref shifted 1))) (if (oddp next) (round-up) (float-from-bits shifted len)))) ;; ;; Otherwise, round up. (t (round-up)))))) #-double-double (defun bignum-to-float (bignum format) (bignum-to-float-float bignum format)) #+double-double (defun bignum-to-float (bignum format) (if (eq format 'double-double-float) (kernel::rational-to-dd bignum) (bignum-to-float-float bignum format))) ;;;; Integer length and logcount #+nil (defun bignum-integer-length (bignum) (declare (type bignum-type bignum)) (let* ((len (%bignum-length bignum)) (len-1 (1- len)) (digit (%bignum-ref bignum len-1))) (declare (type bignum-index len len-1) (type bignum-element-type digit)) (+ (integer-length (%fixnum-digit-with-correct-sign digit)) (* len-1 digit-size)))) (defun bignum-buffer-integer-length (bignum len) (declare (type bignum-type bignum)) (let* ((len-1 (1- len)) (digit (%bignum-ref bignum len-1))) (declare (type bignum-index len len-1) (type bignum-element-type digit)) (+ (integer-length (%fixnum-digit-with-correct-sign digit)) (* len-1 digit-size)))) (defun bignum-integer-length (bignum) (declare (type bignum-type bignum)) (bignum-buffer-integer-length bignum (%bignum-length bignum))) (defun bignum-logcount (bignum) (declare (type bignum-type bignum)) (let* ((length (%bignum-length bignum)) (plusp (%bignum-0-or-plusp bignum length)) (result 0)) (declare (type bignum-index length) (fixnum result)) (do ((index 0 (1+ index))) ((= index length) result) (let ((digit (%bignum-ref bignum index))) (declare (type bignum-element-type digit)) (incf result (logcount (if plusp digit (%lognot digit)))))))) (defun bignum-logbitp (index bignum) (declare (type bignum-type bignum)) ;; For bignums, locate the word we're interested in and test ;; the appropriate bit. As in the fixnum case, if the index ;; is too big, the answer is the sign of the number. (let ((len (bignum::%bignum-length bignum))) (multiple-value-bind (word-index bit-index) (floor index digit-size) (if (>= word-index len) (not (bignum-plus-p bignum)) (not (zerop (logand (ash 1 bit-index) (%bignum-ref bignum word-index)))))))) ;;;; Logical operations. ;;; NOT. ;;; ;;; BIGNUM-LOGICAL-NOT -- Public. ;;; (defun bignum-logical-not (a) (declare (type bignum-type a)) (let* ((len (%bignum-length a)) (res (%allocate-bignum len))) (declare (type bignum-index len)) (dotimes (i len res) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%lognot (%bignum-ref a i)))))) ;;; AND. ;;; ;;; BIGNUM-LOGICAL-AND -- Public. ;;; (defun bignum-logical-and (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) (len-b (%bignum-length b)) (a-plusp (%bignum-0-or-plusp a len-a)) (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((< len-a len-b) (if a-plusp (logand-shorter-positive a len-a b (%allocate-bignum len-a)) (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) ((< len-b len-a) (if b-plusp (logand-shorter-positive b len-b a (%allocate-bignum len-b)) (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) ;;; LOGAND-SHORTER-POSITIVE -- Internal. ;;; ;;; This takes a shorter bignum, a and len-a, that is positive. Because this ;;; is AND, we don't care about any bits longer than a's since its infinite 0 ;;; sign bits will mask the other bits out of b. The result is len-a big. ;;; (defun logand-shorter-positive (a len-a b res) (declare (type bignum-type a b res) (type bignum-index len-a)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logand (%bignum-ref a i) (%bignum-ref b i)))) (%normalize-bignum res len-a)) ;;; LOGAND-SHORTER-NEGATIVE -- Internal. ;;; ;;; This takes a shorter bignum, a and len-a, that is negative. Because this ;;; is AND, we just copy any bits longer than a's since its infinite 1 sign ;;; bits will include any bits from b. The result is len-b big. ;;; (defun logand-shorter-negative (a len-a b len-b res) (declare (type bignum-type a b res) (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logand (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i))) ((= i len-b)) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%bignum-ref b i))) (%normalize-bignum res len-b)) ;;; IOR. ;;; ;;; BIGNUM-LOGICAL-IOR -- Public. ;;; (defun bignum-logical-ior (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) (len-b (%bignum-length b)) (a-plusp (%bignum-0-or-plusp a len-a)) (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((< len-a len-b) (if a-plusp (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) ((< len-b len-a) (if b-plusp (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) ;;; LOGIOR-SHORTER-POSITIVE -- Internal. ;;; ;;; This takes a shorter bignum, a and len-a, that is positive. Because this ;;; is IOR, we don't care about any bits longer than a's since its infinite ;;; 0 sign bits will mask the other bits out of b out to len-b. The result ;;; is len-b long. ;;; (defun logior-shorter-positive (a len-a b len-b res) (declare (type bignum-type a b res) (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logior (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i))) ((= i len-b)) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%bignum-ref b i))) (%normalize-bignum res len-b)) ;;; LOGIOR-SHORTER-NEGATIVE -- Internal. ;;; ;;; This takes a shorter bignum, a and len-a, that is negative. Because this ;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign ;;; bits will include any bits from b. The result is len-b long. ;;; (defun logior-shorter-negative (a len-a b len-b res) (declare (type bignum-type a b res) (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logior (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i)) (sign (%sign-digit a len-a))) ((= i len-b)) (declare (type bignum-index i)) (setf (%bignum-ref res i) sign)) (%normalize-bignum res len-b)) ;;; XOR. ;;; ;;; BIGNUM-LOGICAL-XOR -- Public. ;;; (defun bignum-logical-xor (a b) (declare (type bignum-type a b)) (let ((len-a (%bignum-length a)) (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (if (< len-a len-b) (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) ;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. ;;; ;;; This takes the shorter of two bignums in a and len-a. Res is len-b ;;; long. Do the XOR. ;;; (defun bignum-logical-xor-aux (a len-a b len-b res) (declare (type bignum-type a b res) (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logxor (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i)) (sign (%sign-digit a len-a))) ((= i len-b)) (declare (type bignum-index i)) (setf (%bignum-ref res i) (%logxor sign (%bignum-ref b i)))) (%normalize-bignum res len-b)) ;;;; LDB (load byte) #| FOR NOW WE DON'T USE LDB OR DPB. WE USE SHIFTS AND MASKS IN NUMBERS.LISP WHICH IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! Not really. It doesn't handle negative numbers very well and still needs work. Having said that, I (RLT) think bignum-load-byte and friends is working. |# (defconstant maximum-fixnum-bits #+ibm-rt-pc 27 #-ibm-rt-pc 30) ;;; BIGNUM-LOAD-BYTE -- Public. ;;; (defun bignum-load-byte (byte bignum) (declare (type bignum-type bignum)) (let ((byte-len (byte-size byte)) (byte-pos (byte-position byte))) (if (< byte-len maximum-fixnum-bits) (bignum-ldb-fixnum-res bignum byte-len byte-pos) (bignum-ldb-bignum-res bignum byte-len byte-pos)))) ;;; Create a 32-bit word containing the specified number of 1 bits, ;;; right-justified in the 32-bit word. (declaim (inline %make-ones)) (defun %make-ones (len) (declare (type (integer 0 #.digit-size) len) (optimize (speed 3) (safety 0))) (if (< len digit-size) (1- (ash 1 len)) #.(1- (ash 1 digit-size)))) ;;; BIGNUM-LDB-FIXNUM-RES -- Internal. ;;; ;;; This returns a fixnum result of loading a byte from a bignum. In order, we ;;; check for the following conditions: ;;; Insufficient bignum digits to start loading a byte -- ;;; Return 0 or byte-len 1's depending on sign of bignum. ;;; One bignum digit containing the whole byte spec -- ;;; Grab 'em, shift 'em, and mask out what we don't want. ;;; Insufficient bignum digits to cover crossing a digit boundary -- ;;; Grab the available bits in the last digit, and or in whatever ;;; virtual sign bits we need to return a full byte spec. ;;; Else (we cross a digit boundary with all bits available) -- ;;; Make a couple masks, grab what we want, shift it around, and ;;; LOGIOR it all together. ;;; Because (< maximum-fixnum-bits digit-size) and ;;; (< byte-len maximum-fixnum-bits), ;;; we only cross one digit boundary if any. ;;; (defun bignum-ldb-fixnum-res (bignum byte-len byte-pos) (declare (type (integer 0 29) byte-len) (type (and fixnum unsigned-byte) byte-pos) (optimize (speed 3) (safety 0))) (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size) (let ((bignum-len (%bignum-length bignum)) (s-digits+1 (1+ skipped-digits))) (declare (type bignum-index bignum-len s-digits+1)) (if (>= skipped-digits bignum-len) (if (%bignum-0-or-plusp bignum bignum-len) 0 (%make-ones byte-len)) (let ((end (+ pos byte-len))) (cond ((<= end digit-size) ;; The desired byte is completely contained in the ;; current digit. Extract it out. (logand (%ashr (%bignum-ref bignum skipped-digits) pos) (%make-ones byte-len))) ((>= s-digits+1 bignum-len) ;; The desired byte is in the bignum digit ;; containing the sign. Just extract out the ;; desired part, being careful with the sign. (let* ((available-bits (- digit-size pos)) (res (%digit-logical-shift-right (%bignum-ref bignum skipped-digits) pos))) (if (%bignum-0-or-plusp bignum bignum-len) res (logior (%ashl (%make-ones (- end digit-size)) available-bits) res)))) (t ;; Ok, the desired byte is contained in two digits. ;; Extract out the desired pieces from the two ;; digits and merge them into one. (let* ((high-bits-in-first-digit (- digit-size pos)) (low-bits-in-next-digit (- end digit-size)) (low-mask (%make-ones low-bits-in-next-digit))) (declare (type bignum-element-type low-mask)) (logior (%ashl (logand (%bignum-ref bignum s-digits+1) low-mask) high-bits-in-first-digit) (%digit-logical-shift-right (%bignum-ref bignum skipped-digits) pos)))))))))) ;;; BIGNUM-LDB-BIGNUM-RES -- Internal. ;;; ;;; This returns a bignum result of loading a byte from a bignum. In order, we ;;; check for the following conditions: ;;; Insufficient bignum digits to start loading a byte -- ;;; Byte-pos starting on a digit boundary -- ;;; Byte spec contained in one bignum digit -- ;;; Grab the bits we want and stick them in a single digit result. ;;; Since we know byte-pos is non-zero here, we know our single digit ;;; will have a zero high sign bit. ;;; Else (unaligned multiple digits) -- ;;; This is like doing a shift right combined with either masking ;;; out unwanted high bits from bignum or filling in virtual sign ;;; bits if bignum had insufficient bits. We use SHIFT-RIGHT-ALIGNED ;;; and reference lots of local variables this macro establishes. ;;; (defun bignum-ldb-bignum-res (bignum byte-len byte-pos) (declare (type bignum bignum) (type (and fixnum (integer 33)) byte-len) (type (and fixnum unsigned-byte) byte-pos) (optimize (speed 3))) (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size) (let ((bignum-len (%bignum-length bignum))) (declare (type bignum-index bignum-len)) (cond ((>= skipped-digits bignum-len) (make-bignum-virtual-ldb-bits bignum bignum-len byte-len)) ((zerop pos) (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits)) ((< (+ pos byte-len) digit-size) (let ((res (%allocate-bignum 1))) (setf (%bignum-ref res 0) (logand (%ashr (%bignum-ref bignum skipped-digits) pos) (%make-ones byte-len))) res)) (t (make-unaligned-ldb-bignum bignum bignum-len byte-len skipped-digits pos)))))) ;;; MAKE-BIGNUM-VIRTUAL-LDB-BITS -- Internal. ;;; ;;; This returns bits from bignum that don't physically exist. These are ;;; all zero or one depending on the sign of the bignum. ;;; (defun make-bignum-virtual-ldb-bits (bignum bignum-len byte-len) (declare (type bignum bignum) (type fixnum bignum-len byte-len) (optimize speed)) (if (%bignum-0-or-plusp bignum bignum-len) 0 (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) (declare (type bignum-index res-len-1)) (let* ((res-len (1+ res-len-1)) (res (%allocate-bignum res-len))) (declare (type bignum-index res-len)) (do ((j 0 (1+ j))) ((= j res-len-1) (setf (%bignum-ref res j) (%make-ones extra)) (%normalize-bignum res res-len)) (declare (type bignum-index j)) (setf (%bignum-ref res j) all-ones-digit)))))) ;;; MAKE-ALIGNED-LDB-BIGNUM -- Internal. ;;; ;;; Since we are picking up aligned digits, we just copy the whole digits ;;; we want and fill in extra bits. We might have a byte-len that extends ;;; off the end of the bignum, so we may have to fill in extra 1's if the ;;; bignum is negative. ;;; (defun make-aligned-ldb-bignum (bignum bignum-len byte-len skipped-digits) (declare (type bignum bignum) (type fixnum bignum-len byte-len skipped-digits) (optimize speed)) (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) (declare (type bignum-index res-len-1)) (let* ((res-len (1+ res-len-1)) (res (%allocate-bignum res-len))) (declare (type bignum-index res-len)) (do ((i skipped-digits (1+ i)) (j 0 (1+ j))) ((or (= j res-len-1) (= i bignum-len)) (cond ((< i bignum-len) (setf (%bignum-ref res j) (logand (%bignum-ref bignum i) (the bignum-element-type (%make-ones extra))))) ((%bignum-0-or-plusp bignum bignum-len)) (t (do ((j j (1+ j))) ((= j res-len-1) (setf (%bignum-ref res j) (%make-ones extra))) (setf (%bignum-ref res j) all-ones-digit)))) (%normalize-bignum res res-len)) (declare (type bignum-index i j)) (setf (%bignum-ref res j) (%bignum-ref bignum i)))))) ;;; MAKE-UNALIGNED-LDB-BIGNUM -- Internal. ;;; ;;; This grabs unaligned bignum bits from bignum assuming byte-len causes at ;;; least one digit boundary crossing. We use SHIFT-RIGHT-UNALIGNED referencing ;;; lots of local variables established by it. ;;; (defun make-unaligned-ldb-bignum (bignum bignum-len byte-len skipped-digits pos) (declare (type bignum bignum) (type fixnum bignum-len byte-len skipped-digits) (type (integer 0 32) pos) (optimize speed)) (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) (let* ((low-mask (%make-ones pos) #+nil (1- (ash 1 pos)))) (shift-right-unaligned bignum skipped-digits pos (1+ res-len-1) ((or (= j res-len-1) (= i+1 bignum-len)) (cond ((= j res-len-1) ;; We're here if the bignum result is basically done. (cond ((< extra high-bits-in-first-digit) (setf (%bignum-ref res j) (logand (%digit-logical-shift-right (%bignum-ref bignum i) pos) (%make-ones extra)))) ((= i+1 bignum-len) ;; If we're at the last digit of the bignum, ;; we need to merge in the sign correctly. (setf (%bignum-ref res j) (logand (%digit-logical-shift-right (%bignum-ref bignum i) pos) (%make-ones extra))) (unless (%bignum-0-or-plusp bignum bignum-len) (setf (%bignum-ref res j) (logior (%bignum-ref res j) (%ashl (%make-ones (- extra high-bits-in-first-digit)) high-bits-in-first-digit))))) (t ;; We're not at the last digit, so just grab ;; bits from the current digit, and the next ;; to get the desired result. (setf (%bignum-ref res j) (logand (logior (%digit-logical-shift-right (%bignum-ref bignum i) pos) (%ashl (%bignum-ref bignum i+1) high-bits-in-first-digit)) (%make-ones extra)))))) (t (setf (%bignum-ref res j) (%digit-logical-shift-right (%bignum-ref bignum i) pos)) (unless (%bignum-0-or-plusp bignum bignum-len) ;; Fill in upper half of this result digit with 1's. (setf (%bignum-ref res j) (logior (%bignum-ref res j) (%ashl low-mask high-bits-in-first-digit))) ;; Fill in any extra 1's we need to be byte-len long. (do ((j (1+ j) (1+ j))) ((>= j res-len-1) (setf (%bignum-ref res j) (%make-ones extra))) (setf (%bignum-ref res j) all-ones-digit))))) (%normalize-bignum res res-len)) res)))) ;;;; DPB (deposit byte). (defun bignum-deposit-byte (new-byte byte-spec bignum) (declare (type bignum-type bignum)) (let* ((byte-len (byte-size byte-spec)) (byte-pos (byte-position byte-spec)) (bignum-len (%bignum-length bignum)) (bignum-plusp (%bignum-0-or-plusp bignum bignum-len)) (byte-end (+ byte-pos byte-len)) (res-len (1+ (max (ceiling byte-end digit-size) bignum-len))) (res (%allocate-bignum res-len))) (declare (type bignum-index bignum-len res-len)) (format t "BIGNUM-DEPOSIT-BYTE~%") (format t "bignum-len = ~A~%" bignum-len) (format t "res-len = ~A~%" res-len) ;; ;; Fill in an extra sign digit in case we set what would otherwise be the ;; last digit's last bit. Normalize at the end in case this was ;; unnecessary. (unless bignum-plusp ;; Actually, we need to fill all words past the end of the ;; bignum with sign digits. (dotimes (k (- res-len bignum-len)) (setf (%bignum-ref res (+ k bignum-len)) all-ones-digit))) (multiple-value-bind (end-digit end-bits) (truncate byte-end digit-size) (declare (type bignum-index end-digit)) ;; ;; Fill in bits from bignum up to byte-pos. (multiple-value-bind (pos-digit pos-bits) (truncate byte-pos digit-size) (declare (type bignum-index pos-digit)) (do ((i 0 (1+ i)) (end (min pos-digit bignum-len))) ((= i end) ;;(format t "end = ~A (min ~A ~A)~%" end pos-digit bignum-len) (cond ((< i bignum-len) #| (format t "bignum-dpb: i < bignum-len ~A ~A~%" i bignum-len) (format t " pos-bits = ~A~%" pos-bits) (format t " res = ~:,,,8X~%" (ldb (byte (* (%bignum-length res) 32) 0) res)) |# (unless (zerop pos-bits) (setf (%bignum-ref res i) (logand (%bignum-ref bignum i) (%make-ones pos-bits)))) #+nil (format t " res = ~:,,,8X~%" (ldb (byte (* (%bignum-length res) 32) 0) res)) ) (bignum-plusp) (t ;;(format t "bignum-dpb: T~%") (do ((i i (1+ i))) ((= i pos-digit) (unless (zerop pos-bits) (setf (%bignum-ref res i) (%make-ones pos-bits)))) (setf (%bignum-ref res i) all-ones-digit))))) (setf (%bignum-ref res i) (%bignum-ref bignum i))) ;; ;; Fill in bits from new-byte. (if (typep new-byte 'fixnum) (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits end-digit end-bits res) (deposit-bignum-bits new-byte byte-len pos-digit pos-bits end-digit end-bits res))) ;; ;; Fill in remaining bits from bignum after byte-spec. (Format t "end-digit bignum-len = ~A ~A~%" end-digit bignum-len) (when (<= end-digit bignum-len) (setf (%bignum-ref res end-digit) (logior (logand (%bignum-ref bignum end-digit) (%ashl (%make-ones (- digit-size end-bits)) end-bits)) ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store ;; bits from new-byte into res's end-digit element, so ;; we don't need to mask out unwanted high bits. (%bignum-ref res end-digit))) (do ((i (1+ end-digit) (1+ i))) ((>= i bignum-len)) (setf (%bignum-ref res i) (%bignum-ref bignum i))))) (%normalize-bignum res res-len))) ;;; DEPOSIT-FIXNUM-BITS -- Internal. ;;; ;;; This starts at result's pos-digit skipping pos-bits, and it stores bits ;;; from new-byte, a fixnum, into result. It effectively stores byte-len ;;; number of bits, but never stores past end-digit and end-bits in result. ;;; The first branch fires when all the bits we want from new-byte are present; ;;; if byte-len crosses from the current result digit into the next, the last ;;; argument to DEPOSIT-FIXNUM-DIGIT is a mask for those bits. The second ;;; branch handles the need to grab more bits than the fixnum new-byte has, but ;;; new-byte is positive; therefore, any virtual bits are zero. The mask for ;;; bits that don't fit in the current result digit is simply the remaining ;;; bits in the bignum digit containing new-byte; we don't care if we store ;;; some extra in the next result digit since they will be zeros. The last ;;; branch handles the need to grab more bits than the fixnum new-byte has, but ;;; new-byte is negative; therefore, any virtual bits must be explicitly filled ;;; in as ones. We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist ;;; and to fill in the current result digit. ;;; (defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (let ((other-bits (- digit-size pos-bits)) (new-byte-digit (%fixnum-to-digit new-byte))) (declare (type bignum-element-type new-byte-digit)) (cond ((< byte-len maximum-fixnum-bits) (format t "deposit-fixnum-bits: byte-len < maximum-fixnum-bits~%") (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits other-bits result (- byte-len other-bits))) ;; Can't do this because what happens if new-byte is a ;; fixnum, but the byte-spec is larger than a fixnum? Some ;; of the higher bits may not be set properly. #+nil ((or (plusp new-byte) (zerop new-byte)) (format t "deposit-fixnum-bits: new-byte >= 0~%") (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits other-bits result pos-bits)) (t (format t "deposit-fixnum-bits: T~%") (multiple-value-bind (digit bits) (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits other-bits result (if (< (- byte-len other-bits) digit-size) (- byte-len other-bits) digit-size)) (declare (type bignum-index digit)) (cond ((< digit end-digit) (setf (%bignum-ref result digit) (logior (%bignum-ref result digit) (%ashl (%make-ones (- digit-size bits)) bits))) (do ((i (1+ digit) (1+ i))) ((= i end-digit) (setf (%bignum-ref result i) (%make-ones end-bits))) (setf (%bignum-ref result i) all-ones-digit))) ((> digit end-digit)) ((< bits end-bits) (setf (%bignum-ref result digit) (logior (%bignum-ref result digit) (%ashl (%make-ones (- end-bits bits)) bits)))))))))) ;;; DEPOSIT-FIXNUM-DIGIT -- Internal. ;;; ;;; This fills in the current result digit from new-byte-digit. The first case ;;; handles everything we want fitting in the current digit, and other-bits is ;;; the number of bits remaining to be filled in result's current digit. This ;;; number is digit-size minus pos-bits. The second branch handles filling in ;;; result's current digit, and it shoves the unused bits of new-byte-digit ;;; into the next result digit. This is correct regardless of new-byte-digit's ;;; sign. It returns the new current result digit and how many bits already ;;; filled in the result digit. ;;; (defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits other-bits result next-digit-bits-needed) (declare (type bignum-index pos-digit) (type bignum-element-type new-byte-digit)) (cond ((<= byte-len other-bits) ;; Bits from new-byte fit in the current result digit. (format t "dep-fixnum: byte-len < other-bits~%") (format t " pos-digit = ~A~%" pos-digit) (format t " result = ~:,,,8x~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) (Format t " new-byte-digit = ~X~%" new-byte-digit) (Format t " pos-bits = ~A~%" pos-bits) (format t " byte-len = ~A~%" byte-len) (let ((word (logior (logandc2 (%bignum-ref result pos-digit) (%ashl (%make-ones byte-len) pos-bits)) (%ashl (logand new-byte-digit (%make-ones byte-len)) pos-bits)))) ;;(format t " new word = ~:,,,8x~%" word) (setf (%bignum-ref result pos-digit) word)) (if (= byte-len other-bits) (values (1+ pos-digit) 0) (values pos-digit (+ byte-len pos-bits)))) (t ;; Some of new-byte's bits go in current result digit. (format t "dep-fixnum: T~%") (setf (%bignum-ref result pos-digit) (logior (%bignum-ref result pos-digit) (%ashl (logand new-byte-digit (%make-ones other-bits)) pos-bits))) (Format t " result = ~:,,,8X~%" result) (Format t " result = ~:,,,8X~%" (ldb (byte (* (%bignum-length result) 32) 0) result)) (let ((pos-digit+1 (1+ pos-digit))) (format t " pos-digit = ~A~%" pos-digit) (format t " other-bits = ~A~%" other-bits) (format t " new-byte-digit = ~X~%" new-byte-digit) (format t " Merge in = ~X~%" (logand (%ashr new-byte-digit other-bits) ;; Must LOGAND after shift here. (%make-ones next-digit-bits-needed))) ;; The rest of new-byte's bits go in the next result digit. (format t " next-digit-bits-needed = ~A~%" next-digit-bits-needed) (format t " current digit = ~X~%" (%bignum-ref result pos-digit)) (format t " next-digit = ~X~%" (%bignum-ref result pos-digit+1)) (format t " next-digit+1 = ~X~%" (%bignum-ref result (1+ pos-digit+1))) #+nil (setf (%bignum-ref result pos-digit+1) (logior (logandc2 (%bignum-ref result pos-digit+1) (%make-ones next-digit-bits-needed)) (logand (%ashr new-byte-digit other-bits) ;; Must LOGAND after shift here. (%make-ones next-digit-bits-needed)))) #+nil (setf (%bignum-ref result pos-digit+1) (logand (ash new-byte-digit (- other-bits)) ;; Must LOGAND after shift here. (%make-ones next-digit-bits-needed))) (setf (%bignum-ref result pos-digit+1) (logior (logandc2 (%bignum-ref result pos-digit+1) (%make-ones next-digit-bits-needed)) (logand (ash new-byte-digit (- other-bits)) ;; Must LOGAND after shift here. (%make-ones next-digit-bits-needed)))) #|| (Format t " result = ~:,,,8X~%" result) (Format t " result = ~:,,,8X~%" (ldb (byte (* (%bignum-length result) 32) 0) result)) (format t " next-digit-bits-needed, digit-size = ~A ~A~%" next-digit-bits-needed digit-size) ||# (if (= next-digit-bits-needed digit-size) (values (1+ pos-digit+1) 0) (values pos-digit+1 next-digit-bits-needed)))))) ;;; DEPOSIT-BIGNUM-BITS -- Internal. ;;; ;;; This starts at result's pos-digit skipping pos-bits, and it stores bits ;;; from new-byte, a bignum, into result. It effectively stores byte-len ;;; number of bits, but never stores past end-digit and end-bits in result. ;;; When handling a starting bit unaligned with a digit boundary, we check ;;; in the second branch for the byte spec fitting into the pos-digit element ;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one ;;; digit boundary crossing. ;;; (defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (format t "deposit-bignum-bits: result = ~:,,,8X~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) (format t "deposit-bignum-bits: result = ~:,,,8X~%" result) (cond ((zerop pos-bits) (format t " cond: pos-bits = 0~%") (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits result)) ((or (= end-digit pos-digit) (and (= end-digit (1+ pos-digit)) (zerop end-bits))) (format t " cond: mid~%") (setf (%bignum-ref result pos-digit) (logior (%bignum-ref result pos-digit) (%ashl (logand (%bignum-ref bignum-byte 0) (%make-ones byte-len)) pos-bits)))) (t (format t " cond: T~%") (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits end-digit end-bits result)))) ;;; DEPOSIT-ALIGNED-BIGNUM-BITS -- Internal. ;;; ;;; This deposits bits from bignum-byte into result starting at pos-digit and ;;; the zero'th bit. It effectively only stores bits to end-bits in the ;;; end-digit element of result. The loop termination code takes care of ;;; picking up the last digit's bits or filling in virtual negative sign bits. ;;; (defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (let* ((bignum-len (%bignum-length bignum-byte)) (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))) (declare (type bignum-index bignum-len)) (do ((i 0 (1+ i )) (j pos-digit (1+ j))) ((or (= j end-digit) (= i bignum-len)) (cond ((= j end-digit) (format t " deposit-aligned: j = end-digit (~A)~%" j) (format t " i, bignum-len = ~A ~A~%" i bignum-len) (cond ((< i bignum-len) (format t " result[~A] = ~:,,,8x~%" j (%bignum-ref result j)) (let ((word #+nil (logand (%bignum-ref bignum-byte i) (%make-ones end-bits)) (logior (logandc2 (%bignum-ref result j) (%make-ones end-bits)) (logand (%bignum-ref bignum-byte i) (%make-ones end-bits))))) (format t " new = ~:,,,8x~%" word) (setf (%bignum-ref result j) word))) (bignum-plusp) (t (setf (%bignum-ref result j) (%make-ones end-bits))))) (bignum-plusp) (t (format t " deposit-aligned: cond T~%") (do ((j j (1+ j))) ((= j end-digit) (setf (%bignum-ref result j) (%make-ones end-bits))) (setf (%bignum-ref result j) all-ones-digit))))) (setf (%bignum-ref result j) (%bignum-ref bignum-byte i))))) ;;; DEPOSIT-UNALIGNED-BIGNUM-BITS -- Internal. ;;; ;;; This assumes at least one digit crossing. ;;; (defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (let* ((bignum-len (%bignum-length bignum-byte)) (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)) (low-mask (%make-ones pos-bits)) (bits-past-pos-bits (- digit-size pos-bits)) (high-mask (%make-ones bits-past-pos-bits))) (declare (type bignum-element-type low-mask high-mask) (type bignum-index bignum-len)) (format t " deposit-unaligned: start result = ~:,,,8X~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) (format t " pos-digit = ~A~%" pos-digit) (format t " pos-bits = ~A~%" pos-bits) (format t " end-digit = ~A~%" end-digit) (format t " end-bits = ~A~%" end-bits) ;; i is the word index to bignum-byte ;; j is the word index to the result (do ((i 0 (1+ i)) (j pos-digit j+1) (j+1 (1+ pos-digit) (1+ j+1))) ((or (= j+1 end-digit) (= i bignum-len)) (format t " deposit-unaligned: result = ~:,,,8X~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) (format t " deposit-unaligned: result = ~:,,,8X~%" result) (cond ((= j+1 end-digit) (format t " cond: j = end-digit - 1: ~A ~A-1~%" j end-digit) (format t " pos-bits, end-bits ~A ~A~%" pos-bits end-bits) (setf (%bignum-ref result j+1) (cond ((>= pos-bits end-bits) (format t " cond: pos-bits >= end-bits ~A ~A~%" pos-bits end-bits) (format t " res-digit = ~:,,,8X~%" (%bignum-ref result j+1)) (let* ((digit (%bignum-ref bignum-byte i)) (word (logior (logandc2 (%bignum-ref result j+1) (%make-ones end-bits)) (%digit-logical-shift-right digit bits-past-pos-bits)))) ;; Update previous word too (setf (%bignum-ref result j) (logior (logandc2 (%bignum-ref result j) (%ashl high-mask pos-bits)) (%ashl (logand digit high-mask) pos-bits))) (format t " word = ~:,,,8X~%" word) word)) #+nil ((< i bignum-len) ;; We've reached the end of the result, but we ;; haven't used all of the bignum-byte digits ;; yet. Do so now. (format t " cond: i < bignum-len ~A ~A~%" i bignum-len) (Format t " j = ~A~%" j) (format t " bignum-byte = ~:,,,8X~%" bignum-byte) (format t " end-bits, pos-bits = ~A ~A~%" end-bits pos-bits) (format t " word = ~:,,,8X~%" (%ashl (logand (%bignum-ref bignum-byte i) (%make-ones (- end-bits pos-bits))) pos-bits)) (format t " res word = ~:,,,8X~%" (%bignum-ref result j)) (format t " result = ~:,,,8X~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) (let* ((mask (%make-ones (- end-bits pos-bits))) (word (logior (logandc2 (%bignum-ref result j+1) (%make-ones end-bits)) (%digit-logical-shift-right (%bignum-ref bignum-byte i) bits-past-pos-bits)))) (format t " new word = ~:,,,8X~%" word) (format t " result = ~:,,,8X~%" (ldb (byte (* 32 (%bignum-length result)) 0) result)) ;; Adjust previous word too (setf (%bignum-ref result j) (logior (logandc2 (%bignum-ref result j) (%ashl high-mask pos-bits)) (%ashl (logand (%bignum-ref bignum-byte i) high-mask) pos-bits))) word) ) ((< i bignum-len) ;; We've reached the end of the result, but we ;; haven't used all of the bignum-byte digits ;; yet. Do so now. ;; ;; For i to bignum-len - 1 ;; merge bignum-byte[i] into result j, j+1 ;; merge bignum-byte[bignum-len - 1] into result (format t " cond: i < bignum-len ~A ~A~%" i bignum-len) (Format t " j = ~A~%" j) (format t " bignum-byte = ~:,,,8X~%" bignum-byte) (format t " end-bits, pos-bits = ~A ~A~%" end-bits pos-bits) (do ((i i (1+ i)) (j j j+1) (j+1 j+1 (1+ j+1))) ((>= i (1- bignum-len)) (let* ((mask (%make-ones (- end-bits pos-bits))) (word (logior (logandc2 (%bignum-ref result j) (%ashl mask pos-bits)) (%ashl (logand (%bignum-ref bignum-byte (1- bignum-len)) mask) pos-bits)) )) (format t " bignum-byte[~A] = ~:8,,,8x~%" (1- bignum-len) (%bignum-ref bignum-byte (1- bignum-len))) (format t " result[~A] = ~:8,,,8X~%" j (%bignum-ref result j)) (format t " end-bits, pos-bits = ~A ~A~%" end-bits pos-bits) (format t " res mask = ~:8,,,8X~%" (%ashl (%make-ones end-bits) pos-bits)) (format t " or in = ~:8,,,8X~%" (%ashl (logand (%bignum-ref bignum-byte (1- bignum-len)) high-mask) pos-bits)) (format t " Final result[~A] = ~:8,,,8x~%" j word) word)) (let ((word 0) (digit (%bignum-ref bignum-byte i))) (format t " i, j = ~A ~A~%" i j) (format t " digit = ~@8X~%" digit) ;; Set the top bits of the current result digit with the low ;; bits from the new-byte. (setf word (logior (logandc2 (%bignum-ref result j) (%ashl high-mask pos-bits)) (%ashl (logand digit high-mask) pos-bits))) (format t " Set result[~A] = ~:8,,,8x~%" j word) (setf (%bignum-ref result j) word) ;; Set the low bits of the next result digit with the high ;; bits from the new-byte. (setf word (logior (logandc2 (%bignum-ref result j+1) low-mask) (%digit-logical-shift-right digit bits-past-pos-bits))) (format t " Set result[~A] = ~:8,,,8x~%" j+1 word) (setf (%bignum-ref result j+1) word)))) (bignum-plusp (format t " cond: bignum-plusp~%") (logand (%bignum-ref result j) ;; 0's between pos-bits and end-bits positions. (logior (%ashl (%make-ones (- digit-size end-bits)) end-bits) low-mask))) (t (format t " cond: T~%") (logior (%bignum-ref result j) (%ashl (%make-ones (- end-bits pos-bits)) pos-bits)))))) (bignum-plusp) (t (format t " cond: T~%") (setf (%bignum-ref result j) (%ashl (%make-ones bits-past-pos-bits) pos-bits)) (do ((j j+1 (1+ j))) ((= j end-digit) (setf (%bignum-ref result j) (%make-ones end-bits))) (declare (type bignum-index j)) (setf (%bignum-ref result j) all-ones-digit))))) (declare (type bignum-index i j j+1)) (let ((digit (%bignum-ref bignum-byte i)) (word 0)) (declare (type bignum-element-type digit)) ;; Set the top bits of the current result digit with the low ;; bits from the new-byte. (setf word (logior (logandc2 (%bignum-ref result j) (%ashl high-mask pos-bits)) (%ashl (logand digit high-mask) pos-bits))) (format t " Set ~A (~:,,,8x) to ~:,,,8x~%" j (%bignum-ref result j) word) (format t " mask = ~:,,,8x~%" high-mask) (setf (%bignum-ref result j) word) (Format t " bits-post-post-bits = ~A~%" bits-past-pos-bits) ;; Set the low bits of the next result digit with the high ;; bits from the new-byte. (setf word #+nil (logand (ash digit minus-high-bits) ;; LOGAND should be unnecessary here with a logical right ;; shift or a correct unsigned-byte-32 one. low-mask) (logior (logandc2 (%bignum-ref result j+1) low-mask) (%digit-logical-shift-right digit bits-past-pos-bits))) (Format t " low mask = ~x~%" low-mask) (format t " Set next ~A (~:,,,8x) to ~:,,,8x~%" j+1 (%bignum-ref result j+1) word) (format t " result[j+1] = ~:,,,8x~%" (%bignum-ref result j+1)) (format t " shifted digit = ~:,,,8x~%" (%digit-logical-shift-right digit bits-past-pos-bits)) (setf (%bignum-ref result j+1) word))))) ;;|# ;;;; TRUNCATE. ;;; This is the original sketch of the algorithm from which I implemented this ;;; TRUNCATE, assuming both operands are bignums. I should modify this to work ;;; with the documentation on my functions, as a general introduction. I've ;;; left this here just in case someone needs it in the future. Don't look ;;; at this unless reading the functions' comments leaves you at a loss. ;;; Remember this comes from Knuth, so the book might give you the right general ;;; overview. ;;; ;;; ;;; (truncate x y): ;;; ;;; If X's magnitude is less than Y's, then result is 0 with remainder X. ;;; ;;; Make x and y positive, copying x if it is already positive. ;;; ;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign ;;; digit) ;;; Just do most sig digit to determine how much to shift whole number. ;;; Shift x this much too. ;;; Remember this initial shift count. ;;; ;;; Allocate q to be len-x minus len-y quantity plus 1. ;;; ;;; i = last digit of x. ;;; k = last digit of q. ;;; ;;; LOOP ;;; ;;; j = last digit of y. ;;; ;;; compute guess. ;;; if x[i] = y[j] then g = #xFFFFFFFF ;;; else g = x[i]x[i-1]/y[j]. ;;; ;;; check guess. ;;; %UNSIGNED-MULTIPLY returns b and c defined below. ;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). ;;; Use %UNSIGNED-MULTIPLY taking low-order result. ;;; b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF). ;;; c = (logand (* g y[j-1]) #xFFFFFFFF). ;;; if a < b, okay. ;;; if a > b, guess is too high ;;; g = g - 1; go back to "check guess". ;;; if a = b and c > x[i-2], guess is too high ;;; g = g - 1; go back to "check guess". ;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER ;;; SAME FOR A, B, AND C. ;;; ;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. ;;; If x[i] < 0, guess is fucked. ;;; negative g, then add 1 ;;; zero or positive g, then subtract 1 ;;; AND add y back into x[len-y+1..i]. ;;; ;;; q[k] = g. ;;; i = i - 1. ;;; k = k - 1. ;;; ;;; If k>=0, goto LOOP. ;;; ;;; ;;; Now quotient is good, but remainder is not. ;;; Shift x right by saved initial left shifting count. ;;; ;;; Check quotient and remainder signs. ;;; x pos y pos --> q pos r pos ;;; x pos y neg --> q neg r pos ;;; x neg y pos --> q neg r neg ;;; x neg y neg --> q pos r neg ;;; ;;; Normalize quotient and remainder. Cons result if necessary. ;;; (declaim (ext:start-block bignum-truncate)) ;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. ;;; ;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes ;;; up the quotient and remainder with respect to sign and normalization. ;;; ;;; We don't have to worry about shifting y to make its most significant digit ;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit ;;; and r-digit. If y is a single digit bignum, it is already large enough ;;; for %FLOOR. That is, it has some bits on pretty high in the digit. ;;; (defun bignum-truncate-single-digit (x len-x y) (declare (type bignum-index len-x)) (let ((q (%allocate-bignum len-x)) (r 0) (y (%bignum-ref y 0))) (declare (type bignum-element-type r y)) (do ((i (1- len-x) (1- i))) ((minusp i)) (multiple-value-bind (q-digit r-digit) (%floor r (%bignum-ref x i) y) (declare (type bignum-element-type q-digit r-digit)) (setf (%bignum-ref q i) q-digit) (setf r r-digit))) (let ((rem (%allocate-bignum 1))) (setf (%bignum-ref rem 0) r) (values q rem)))) ;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This takes a digit guess, multiplies it by truncate-y for a result one ;;; greater in length than len-y, and subtracts this result from truncate-x. ;;; Low-x-digit is the first digit of x to start the subtraction, and we know x ;;; is long enough to subtract a len-y plus one length bignum from it. Next we ;;; check the result of the subtraction, and if the high digit in x became ;;; negative, then our guess was one too big. In this case, return one less ;;; than guess passed in, and add one value of y back into x to account for ;;; subtracting one too many. Knuth shows that the guess is wrong on the order ;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. ;;; (defun try-bignum-truncate-guess (guess len-y low-x-digit truncate-x truncate-y) (declare (type bignum-index low-x-digit len-y) (type bignum-element-type guess) (type bignum-type truncate-x truncate-y)) (let ((carry-digit 0) (borrow 1) (i low-x-digit)) (declare (type bignum-element-type carry-digit) (type bignum-index i) (fixnum borrow)) ;; Multiply guess and divisor, subtracting from dividend simultaneously. (dotimes (j len-y) (multiple-value-bind (high-digit low-digit) (%multiply-and-add guess (%bignum-ref truncate-y j) carry-digit) (declare (type bignum-element-type high-digit low-digit)) (setf carry-digit high-digit) (multiple-value-bind (x temp-borrow) (%subtract-with-borrow (%bignum-ref truncate-x i) low-digit borrow) (declare (type bignum-element-type x) (fixnum temp-borrow)) (setf (%bignum-ref truncate-x i) x) (setf borrow temp-borrow))) (incf i)) (setf (%bignum-ref truncate-x i) (%subtract-with-borrow (%bignum-ref truncate-x i) carry-digit borrow)) ;; See if guess is off by one, adding one Y back in if necessary. (cond ((%digit-0-or-plusp (%bignum-ref truncate-x i)) guess) (t ;; If subtraction has negative result, add one divisor value back ;; in. The guess was one too large in magnitude. (let ((i low-x-digit) (carry 0)) (dotimes (j len-y) (multiple-value-bind (v k) (%add-with-carry (%bignum-ref truncate-y j) (%bignum-ref truncate-x i) carry) (declare (type bignum-element-type v)) (setf (%bignum-ref truncate-x i) v) (setf carry k)) (incf i)) (setf (%bignum-ref truncate-x i) (%add-with-carry (%bignum-ref truncate-x i) 0 carry))) (%subtract-with-borrow guess 1 1))))) ;;; DO-TRUNCATE -- Internal. ;;; ;;; This divides truncate-x by truncate-y, and len-x and len-y tell us how ;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies ;;; truncate-x on each interation, and this buffer becomes our remainder. ;;; ;;; truncate-x definitely has at least three digits, and it has one more than ;;; truncate-y. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. ;;; (defun do-truncate (len-x len-y truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type bignum-type truncate-x truncate-y)) (let* ((len-q (- len-x len-y)) ;; Add one for extra sign digit in case high bit is on. (q (%allocate-bignum (1+ len-q))) (k (1- len-q)) (y1 (%bignum-ref truncate-y (1- len-y))) (y2 (%bignum-ref truncate-y (- len-y 2))) (i (1- len-x)) (i-1 (1- i)) (i-2 (1- i-1)) (low-x-digit (- i len-y))) (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess ;; This modifies truncate-x. Must access elements each pass. (bignum-truncate-guess y1 y2 (%bignum-ref truncate-x i) (%bignum-ref truncate-x i-1) (%bignum-ref truncate-x i-2)) len-y low-x-digit truncate-x truncate-y)) (cond ((zerop k) (return)) (t (decf k) (decf low-x-digit) (shiftf i i-1 i-2 (1- i-2))))) q)) ;;; BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This returns a guess for the next division step. Y1 is the highest y ;;; digit, and y2 is the second to highest y digit. The x... variables are ;;; the three highest x digits for the next division step. ;;; ;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1, ;;; depending on whether x-i and y1 are the same. We test this guess by ;;; determining whether guess*y2 is greater than the three high digits of x ;;; minus guess*y1 shifted left one digit: ;;; ------------------------------ ;;; | x-i | x-i-1 | x-i-2 | ;;; ------------------------------ ;;; ------------------------------ ;;; - | g*y1 high | g*y1 low | 0 | ;;; ------------------------------ ;;; ... < guess*y2 ??? ;;; If guess*y2 is greater, then we decrement our guess by one and try again. ;;; This returns a guess that is either correct or one too large. ;;; (defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) (let ((guess (if (%digit-compare x-i y1) all-ones-digit (%floor x-i x-i-1 y1)))) (declare (type bignum-element-type guess)) (loop (multiple-value-bind (high-guess*y1 low-guess*y1) (%multiply guess y1) (declare (type bignum-element-type low-guess*y1 high-guess*y1)) (multiple-value-bind (high-guess*y2 low-guess*y2) (%multiply guess y2) (declare (type bignum-element-type high-guess*y2 low-guess*y2)) (multiple-value-bind (middle-digit borrow) (%subtract-with-borrow x-i-1 low-guess*y1 1) (declare (type bignum-element-type middle-digit) (fixnum borrow)) ;; Supplying borrow of 1 means there was no borrow, and we know ;; x-i-2 minus 0 requires no borrow. (let ((high-digit (%subtract-with-borrow x-i high-guess*y1 borrow))) (declare (type bignum-element-type high-digit)) (if (and (%digit-compare high-digit 0) (or (%digit-greater high-guess*y2 middle-digit) (and (%digit-compare middle-digit high-guess*y2) (%digit-greater low-guess*y2 x-i-2)))) (setf guess (%subtract-with-borrow guess 1 1)) (return guess))))))))) ;;; SHIFT-Y-FOR-TRUNCATE -- Internal. ;;; ;;; This returns the amount to shift y to place a one in the second highest ;;; bit. Y must be positive. If the last digit of y is zero, then y has a ;;; one in the previous digit's sign bit, so we know it will take one less ;;; than digit-size to get a one where we want. Otherwise, we count how many ;;; right shifts it takes to get zero; subtracting this value from digit-size ;;; tells us how many high zeros there are which is one more than the shift ;;; amount sought. ;;; ;;; Note: This is exactly the same as one less than the integer-length of the ;;; last digit subtracted from the digit-size. ;;; ;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit ;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. ;;; (declaim (inline shift-y-for-truncate)) (defun shift-y-for-truncate (y) (let* ((len (%bignum-length y)) (last (%bignum-ref y (1- len)))) (declare (type bignum-index len) (type bignum-element-type last)) (- digit-size (integer-length last) 1))) ;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal. ;;; ;;; Stores two bignums into the truncation bignum buffers, shifting them on the ;;; way in. This assumes x and y are positive and at least two in length, and ;;; it assumes truncate-x and truncate-y are one digit longer than x and y. ;;; (defun shift-and-store-truncate-buffers (x len-x y len-y shift truncate-x truncate-y) (declare (type bignum-index len-x len-y) (type (integer 0 (#.digit-size)) shift) (type bignum-type truncate-x truncate-y)) (cond ((zerop shift) (bignum-replace truncate-x x :end1 len-x) (bignum-replace truncate-y y :end1 len-y)) (t (bignum-ashift-left-unaligned x 0 shift (1+ len-x) truncate-x) (bignum-ashift-left-unaligned y 0 shift (1+ len-y) truncate-y)))) ;;; BIGNUM-TRUNCATE -- Public. ;;; ;;; This divides x by y returning the quotient and remainder. In the general ;;; case, we shift y to setup for the algorithm, and we use two buffers to save ;;; consing intermediate values. X gets destructively modified to become the ;;; remainder, and we have to shift it to account for the initial Y shift. ;;; After we multiple bind q and r, we first fix up the signs and then return ;;; the normalized results. ;;; (defun bignum-truncate (x y) (declare (type bignum-type x y) (optimize (speed 3))) (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) (x (if x-plusp x (negate-bignum x nil))) (y (if y-plusp y (negate-bignum y nil))) (len-x (%bignum-length x)) (len-y (%bignum-length y))) (multiple-value-bind (q r) (cond ((< len-y 2) (bignum-truncate-single-digit x len-x y)) ((plusp (bignum-compare y x)) (let ((res (%allocate-bignum len-x))) (dotimes (i len-x) (setf (%bignum-ref res i) (%bignum-ref x i))) (values 0 res))) (t (let ((len-x+1 (1+ len-x))) (with-bignum-buffers ((truncate-x len-x+1) (truncate-y (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift truncate-x truncate-y) (values (do-truncate len-x+1 len-y truncate-x truncate-y) ;; DO-TRUNCATE must execute first. (cond ((zerop y-shift) (let ((res (%allocate-bignum len-y))) (declare (type bignum-type res)) (bignum-replace res truncate-x :end2 len-y) (%normalize-bignum res len-y))) (t (shift-right-unaligned truncate-x 0 y-shift len-y ((= j res-len-1) (setf (%bignum-ref res j) (%ashr (%bignum-ref truncate-x i) y-shift)) (%normalize-bignum res res-len)) res))))))))) (let ((quotient (cond ((eq x-plusp y-plusp) q) ((typep q 'fixnum) (the fixnum (- q))) (t (negate-bignum-in-place q)))) (rem (cond (x-plusp r) ((typep r 'fixnum) (the fixnum (- r))) (t (negate-bignum-in-place r))))) (values (if (typep quotient 'fixnum) quotient (%normalize-bignum quotient (%bignum-length quotient))) (if (typep rem 'fixnum) rem (%normalize-bignum rem (%bignum-length rem)))))))) (declaim (ext:end-block)) ;;;; %FLOOR primitive for BIGNUM-TRUNCATE. ;;; When a machine leaves out a 64-bit by 32-bit divide instruction (that is, ;;; two bignum-digits divided by one), we have to roll our own (the hard way). ;;; Basically, we treat the operation as four 16-bit digits divided by two ;;; 16-bit digits. This means we have duplicated most of the code above to do ;;; this nearly general 16-bit digit bignum divide, but we've unrolled loops ;;; and made use of other properties of this specific divide situation. ;;; ;;; ;;; %FLOOR for machines with a 32x32 divider. ;;; #+32x16-divide (declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry 32x16-divide 32x16-multiply 32x16-multiply-split)) #+32x16-divide (defconstant 32x16-base-1 #xFFFF) ;;; 32X16-SUBTRACT-WITH-BORROW -- Internal. [optionally IN ASSEMBLER] ;;; ;;; This is similar to %SUBTRACT-WITH-BORROW. It returns a 16-bit difference ;;; and a borrow. Returning a 1 for the borrow means there was no borrow, and ;;; 0 means there was one. ;;; #+32x16-divide (defun 32x16-subtract-with-borrow (a b borrow) (declare (type (unsigned-byte 16) a b) (type (integer 0 1) borrow)) (let ((diff (+ (- a b) borrow 32x16-base-1))) (declare (type (unsigned-byte 17) diff)) (values (logand diff #xFFFF) (ash diff -16)))) ;;; 32X16-ADD-WITH-CARRY -- Internal. [optionally IN ASSEMBLER] ;;; ;;; This adds a and b, 16-bit quantities, with the carry k. It returns a ;;; 16-bit sum and a second value, 0 or 1, indicating whether there was a ;;; carry. ;;; #+32x16-divide (defun 32x16-add-with-carry (a b k) (declare (type (unsigned-byte 16) a b) (type (integer 0 1) k)) (let ((res (the fixnum (+ a b k)))) (declare (type (unsigned-byte 17) res)) (if (zerop (the fixnum (logand #x10000 res))) (values res 0) (values (the (unsigned-byte 16) (logand #xFFFF res)) 1)))) ;;; 32x16-DIVIDE -- Internal [IN ASSEMBLER] ;;; ;;; This is probably a 32-bit by 32-bit divide instruction. ;;; #+32x16-divide (defun 32x16-divide (a b c) (declare (type (unsigned-byte 16) a b c)) (floor (the bignum-element-type (logior (the bignum-element-type (ash a 16)) b)) c)) ;;; 32X16-MULTIPLY -- Internal. [optionally IN ASSEMBLER] ;;; ;;; This basically exists since we know the answer won't overflow ;;; bignum-element-type. It's probably just a basic multiply instruction, but ;;; it can't cons an intermediate bignum. The result goes in a non-descriptor ;;; register. ;;; #+32x16-divide (defun 32x16-multiply (a b) (declare (type (unsigned-byte 16) a b)) (the bignum-element-type (* a b))) ;;; 32X16-MULTIPLY-SPLIT -- Internal. [optionally IN ASSEMBLER] ;;; ;;; This multiplies a and b, 16-bit quantities, and returns the result as two ;;; 16-bit quantities, high and low. ;;; #+32x16-divide (defun 32x16-multiply-split (a b) (let ((res (32x16-multiply a b))) (declare (the bignum-element-type res)) (values (the (unsigned-byte 16) (logand #xFFFF (ash res -16))) (the (unsigned-byte 16) (logand #xFFFF res))))) ;;; The %FLOOR below uses this buffer the same way BIGNUM-TRUNCATE uses ;;; *truncate-x*. There's no y buffer since we pass around the two 16-bit ;;; digits and use them slightly differently than the general truncation ;;; algorithm above. ;;; #+32x16-divide (defvar *32x16-truncate-x* (make-array 4 :element-type '(unsigned-byte 16) :initial-element 0)) ;;; %FLOOR -- Internal. LEFT IMPLEMENTED AT LISP LEVEL ;;; ;;; This does the same thing as the %FLOOR above, but it does it at Lisp level ;;; when there is no 64x32-bit divide instruction on the machine. ;;; ;;; It implements the higher level tactics of BIGNUM-TRUNCATE, but it makes use ;;; of special situation provided, four 16-bit digits divided by two 16-bit ;;; digits. ;;; #+32x16-divide (defun %floor (a b c) (declare (type bignum-element-type a b c)) ;; ;; Setup *32x16-truncate-x* buffer from a and b. (setf (aref *32x16-truncate-x* 0) (the (unsigned-byte 16) (logand #xFFFF b))) (setf (aref *32x16-truncate-x* 1) (the (unsigned-byte 16) (logand #xFFFF (the (unsigned-byte 16) (ash b -16))))) (setf (aref *32x16-truncate-x* 2) (the (unsigned-byte 16) (logand #xFFFF a))) (setf (aref *32x16-truncate-x* 3) (the (unsigned-byte 16) (logand #xFFFF (the (unsigned-byte 16) (ash a -16))))) ;; ;; From DO-TRUNCATE, but unroll the loop. (let* ((y1 (logand #xFFFF (ash c -16))) (y2 (logand #xFFFF c)) (q (the bignum-element-type (ash (32x16-try-bignum-truncate-guess (32x16-truncate-guess y1 y2 (aref *32x16-truncate-x* 3) (aref *32x16-truncate-x* 2) (aref *32x16-truncate-x* 1)) y1 y2 1) 16)))) (declare (type bignum-element-type q) (type (unsigned-byte 16) y1 y2)) (values (the bignum-element-type (logior q (the (unsigned-byte 16) (32x16-try-bignum-truncate-guess (32x16-truncate-guess y1 y2 (aref *32x16-truncate-x* 2) (aref *32x16-truncate-x* 1) (aref *32x16-truncate-x* 0)) y1 y2 0)))) (the bignum-element-type (logior (the bignum-element-type (ash (aref *32x16-truncate-x* 1) 16)) (the (unsigned-byte 16) (aref *32x16-truncate-x* 0))))))) ;;; 32X16-TRY-BIGNUM-TRUNCATE-GUESS -- Internal. ;;; ;;; This is similar to TRY-BIGNUM-TRUNCATE-GUESS, but this unrolls the two ;;; loops. This also substitutes for %DIGIT-0-OR-PLUSP the equivalent ;;; expression without any embellishment or pretense of abstraction. The first ;;; loop is unrolled, but we've put the body of the loop into the function ;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT. ;;; #+32x16-divide (defun 32x16-try-bignum-truncate-guess (guess y-high y-low low-x-digit) (declare (type bignum-index low-x-digit) (type (unsigned-byte 16) guess y-high y-low)) (let ((high-x-digit (+ 2 low-x-digit))) ;; ;; Multiply guess and divisor, subtracting from dividend simultaneously. (multiple-value-bind (guess*y-hold carry borrow) (32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit) (declare (type (unsigned-byte 16) guess*y-hold) (fixnum carry borrow)) (multiple-value-bind (guess*y-hold carry borrow) (32x16-try-guess-one-result-digit guess y-high guess*y-hold carry borrow (1+ low-x-digit)) (declare (type (unsigned-byte 16) guess*y-hold) (fixnum borrow) (ignore carry)) (setf (aref *32x16-truncate-x* high-x-digit) (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit) guess*y-hold borrow)))) ;; ;; See if guess is off by one, adding one Y back in if necessary. (cond ((zerop (logand #x8000 (aref *32x16-truncate-x* high-x-digit))) ;; The subtraction result is zero or positive. guess) (t ;; If subtraction has negative result, add one divisor value back in. ;; The guess was one two large in magnitude. (multiple-value-bind (v carry) (32x16-add-with-carry y-low (aref *32x16-truncate-x* low-x-digit) 0) (declare (type (unsigned-byte 16) v)) (setf (aref *32x16-truncate-x* low-x-digit) v) (multiple-value-bind (v carry) (32x16-add-with-carry y-high (aref *32x16-truncate-x* (1+ low-x-digit)) carry) (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v) (setf (aref *32x16-truncate-x* high-x-digit) (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit) carry 0)))) (if (zerop (logand #x8000 guess)) (1- guess) (1+ guess)))))) ;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT -- Internal. ;;; ;;; This is similar to the body of the loop in TRY-BIGNUM-TRUNCATE-GUESS that ;;; multiplies the guess by y and subtracts the result from x simultaneously. ;;; This returns the digit remembered as part of the multiplication, the carry ;;; from additions done on behalf of the multiplication, and the borrow from ;;; doing the subtraction. ;;; #+32x16-divide (defun 32x16-try-guess-one-result-digit (guess y-digit guess*y-hold carry borrow x-index) (multiple-value-bind (high-digit low-digit) (32x16-multiply-split guess y-digit) (declare (type (unsigned-byte 16) high-digit low-digit)) (multiple-value-bind (low-digit temp-carry) (32x16-add-with-carry low-digit guess*y-hold carry) (declare (type (unsigned-byte 16) low-digit)) (multiple-value-bind (high-digit temp-carry) (32x16-add-with-carry high-digit temp-carry 0) (declare (type (unsigned-byte 16) high-digit)) (multiple-value-bind (x temp-borrow) (32x16-subtract-with-borrow (aref *32x16-truncate-x* x-index) low-digit borrow) (declare (type (unsigned-byte 16) x)) (setf (aref *32x16-truncate-x* x-index) x) (values high-digit temp-carry temp-borrow)))))) ;;; 32X16-TRUNCATE-GUESS -- Internal. ;;; ;;; This is similar to BIGNUM-TRUNCATE-GUESS, but instead of computing the ;;; guess exactly as described in the its comments (digit by digit), this ;;; massages the 16-bit quantities into 32-bit quantities and performs the ;;; #+32x16-divide (defun 32x16-truncate-guess (y1 y2 x-i x-i-1 x-i-2) (declare (type (unsigned-byte 16) y1 y2 x-i x-i-1 x-i-2)) (let ((guess (if (= x-i y1) #xFFFF (32x16-divide x-i x-i-1 y1)))) (declare (type (unsigned-byte 16) guess)) (loop (let* ((guess*y1 (the bignum-element-type (ash (logand #xFFFF (the bignum-element-type (32x16-multiply guess y1))) 16))) (x-y (%subtract-with-borrow (the bignum-element-type (logior (the bignum-element-type (ash x-i-1 16)) x-i-2)) guess*y1 1)) (guess*y2 (the bignum-element-type (%multiply guess y2)))) (declare (type bignum-element-type guess*y1 x-y guess*y2)) (if (%digit-greater guess*y2 x-y) (decf guess) (return guess)))))) ;;;; General utilities. ;;; %NORMALIZE-BIGNUM-BUFFER -- Internal. ;;; ;;; Internal in-place operations use this to fixup remaining digits in the ;;; incoming data, such as in-place shifting. This is basically the same as ;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer ;;; instead of shrinking the bignum. ;;; #+nil(declaim (ext:maybe-inline %normalize-bignum-buffer)) (defun %normalize-bignum-buffer (result len) (declare (type bignum-type result) (type bignum-index len)) (unless (= len 1) (do ((next-digit (%bignum-ref result (- len 2)) (%bignum-ref result (- len 2))) (sign-digit (%bignum-ref result (1- len)) next-digit)) ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) (decf len) (setf (%bignum-ref result len) 0) (when (= len 1) (return)))) len) ;;; %NORMALIZE-BIGNUM -- Internal. ;;; ;;; This drops the last digit if it is unnecessary sign information. It ;;; repeats this as needed, possibly ending with a fixnum. If the resulting ;;; length from shrinking is one, see if our one word is a fixnum. Shift the ;;; possible fixnum bits completely out of the word, and compare this with ;;; shifting the sign bit all the way through. If the bits are all 1's or 0's ;;; in both words, then there are just sign bits between the fixnum bits and ;;; the sign bit. If we do have a fixnum, shift it over for the two low-tag ;;; bits. ;;; (defun %normalize-bignum (result len) (declare (type bignum-type result) (type bignum-index len) #+nil(inline %normalize-bignum-buffer)) (let ((newlen (%normalize-bignum-buffer result len))) (declare (type bignum-index newlen)) (unless (= newlen len) (%bignum-set-length result newlen)) (if (= newlen 1) (let ((digit (%bignum-ref result 0))) (if (= (%ashr digit #+amd64 61 #-amd64 29) (%ashr digit (1- digit-size))) (%fixnum-digit-with-correct-sign digit) result)) result))) ;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. ;;; ;;; This drops the last digit if it is unnecessary sign information. It ;;; repeats this as needed, possibly ending with a fixnum magnitude but never ;;; returning a fixnum. ;;; (defun %mostly-normalize-bignum (result len) (declare (type bignum-type result) (type bignum-index len) #+nil(inline %normalize-bignum-buffer)) (let ((newlen (%normalize-bignum-buffer result len))) (declare (type bignum-index newlen)) (unless (= newlen len) (%bignum-set-length result newlen)) result)) cmucl-21a/src/code/bit-bash.lisp000066400000000000000000000732501260377556400166530ustar00rootroot00000000000000;;; -*- Log: code.log; Package: VM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/bit-bash.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions to implement bit bashing. ;;; ;;; Written by William Lott. ;;; (in-package "VM") (intl:textdomain "cmucl") ;;;; Constants and Types. (eval-when (compile load eval) (defconstant unit-bits vm:word-bits "The number of bits to process at a time.") (defconstant unit-bytes vm:word-bytes "The number of bytes to process at a time.") (defconstant max-bits (1- (ash 1 vm:word-bits)) "The maximum number of bits that can be dealt with during a single call.") (deftype unit () `(unsigned-byte ,unit-bits)) (deftype offset () `(integer 0 ,max-bits)) (deftype bit-offset () `(integer 0 (,unit-bits))) (deftype byte-offset () `(integer 0 (,unit-bytes))) (deftype bit-count () `(integer 1 (,unit-bits))) (deftype word-offset () `(integer 0 (,(ceiling max-bits unit-bits)))) ); eval-when ;;;; Support routines. ;;; A particular implementation must offer either VOPs to translate these, or ;;; deftransforms to convert them into something supported by the architecture. ;;; (macrolet ((frob (name &rest args) `(defun ,name ,args (,name ,@args)))) (frob 32bit-logical-not x) (frob 32bit-logical-and x y) (frob 32bit-logical-or x y) (frob 32bit-logical-xor x y) (frob 32bit-logical-nor x y) (frob 32bit-logical-eqv x y) (frob 32bit-logical-nand x y) (frob 32bit-logical-andc1 x y) (frob 32bit-logical-andc2 x y) (frob 32bit-logical-orc1 x y) (frob 32bit-logical-orc2 x y)) (eval-when (compile eval) (defmacro byte-order-dispatch (big-endian little-endian) (ecase (c:backend-byte-order c:*target-backend*) (:big-endian big-endian) (:little-endian little-endian)))) (defun shift-towards-start (number count) "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing bits from the ``start.'' On big-endian machines this is a left-shift and on little-endian machines this is a right-shift. Note: only the low 5/6 bits of count are significant." (declare (type unit number) (fixnum count)) (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) (declare (type bit-offset count)) (if (zerop count) number (byte-order-dispatch (ash (ldb (byte (- unit-bits count) 0) number) count) (ash number (- count)))))) (defun shift-towards-end (number count) "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing bits from the ``end.'' On big-endian machines this is a right-shift and on little-endian machines this is a left-shift." (declare (type unit number) (fixnum count)) (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) (declare (type bit-offset count)) (if (zerop count) number (byte-order-dispatch (ash number (- count)) (ash (ldb (byte (- unit-bits count) 0) number) count))))) (declaim (inline start-mask end-mask fix-sap-and-offset)) (defun start-mask (count) "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant." (declare (fixnum count)) (shift-towards-start (1- (ash 1 unit-bits)) (- count))) (defun end-mask (count) "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for the remaining ``start'' bits. Only the lower 5 bits of COUNT are significant." (declare (fixnum count)) (shift-towards-end (1- (ash 1 unit-bits)) (- count))) (defun fix-sap-and-offset (sap offset) "Align the SAP to a word boundry, and update the offset accordingly." (declare (type system-area-pointer sap) (type index offset) (values system-area-pointer index)) (let ((address (sap-int sap))) (values (int-sap #-(or alpha amd64) (32bit-logical-andc2 address 3) #+alpha (ash (ash address -2) 2) #+amd64 (ash (ash address -3) 3)) (+ (* (logand address #+amd64 7 #-amd64 3) byte-bits) offset)))) (declaim (inline word-sap-ref %set-word-sap-ref)) ;;; (defun word-sap-ref (sap offset) (declare (type system-area-pointer sap) (type index offset) (values (unsigned-byte #+amd64 64 #-amd64 32)) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) #+amd64 (sap-ref-64 sap (the index (ash offset 3))) #-amd64 (sap-ref-32 sap (the index (ash offset 2)))) ;;; (defun %set-word-sap-ref (sap offset value) (declare (type system-area-pointer sap) (type index offset) (type (unsigned-byte #+amd64 64 #-amd64 32) value) (values (unsigned-byte #+amd64 64 #-amd64 32)) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (setf #+amd64 (sap-ref-64 sap (the index (ash offset 3))) #-amd64 (sap-ref-32 sap (the index (ash offset 2))) value)) ;;; (defsetf word-sap-ref %set-word-sap-ref) ;;;; DO-CONSTANT-BIT-BASH (declaim (inline do-constant-bit-bash)) (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn) "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits." (declare (type offset dst-offset) (type unit value) (type function dst-ref-fn dst-set-fn)) (multiple-value-bind (dst-word-offset dst-bit-offset) (floor dst-offset unit-bits) (declare (type word-offset dst-word-offset) (type bit-offset dst-bit-offset)) (multiple-value-bind (words final-bits) (floor (+ dst-bit-offset length) unit-bits) (declare (type word-offset words) (type bit-offset final-bits)) (if (zerop words) (unless (zerop length) (funcall dst-set-fn dst dst-word-offset (if (= length unit-bits) value (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))) (declare (type unit mask)) (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) mask)))))) (let ((interior (floor (- length final-bits) unit-bits))) (unless (zerop dst-bit-offset) (let ((mask (end-mask (- dst-bit-offset)))) (declare (type unit mask)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) mask)))) (incf dst-word-offset)) (dotimes (i interior) (funcall dst-set-fn dst dst-word-offset value) (incf dst-word-offset)) (unless (zerop final-bits) (let ((mask (start-mask final-bits))) (declare (type unit mask)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) mask))))))))) (undefined-value)) ;;;; DO-UNARY-BIT-BASH (declaim (inline do-unary-bit-bash)) (defun do-unary-bit-bash (src src-offset dst dst-offset length dst-ref-fn dst-set-fn src-ref-fn) (declare (type offset src-offset dst-offset length) (type function dst-ref-fn dst-set-fn src-ref-fn)) (multiple-value-bind (dst-word-offset dst-bit-offset) (floor dst-offset unit-bits) (declare (type word-offset dst-word-offset) (type bit-offset dst-bit-offset)) (multiple-value-bind (src-word-offset src-bit-offset) (floor src-offset unit-bits) (declare (type word-offset src-word-offset) (type bit-offset src-bit-offset)) (cond ((<= (+ dst-bit-offset length) unit-bits) ;; We are only writing one word, so it doesn't matter what order ;; we do it in. But we might be reading from multiple words, so take ;; care. (cond ((zerop length) ;; Actually, we aren't even writing one word. This is real easy. ) ((= length unit-bits) ;; dst-bit-offset must be equal to zero, or we would be writing ;; multiple words. If src-bit-offset is also zero, then we ;; just transfer the single word. Otherwise we have to extract bits ;; from two src words. (funcall dst-set-fn dst dst-word-offset (if (zerop src-bit-offset) (funcall src-ref-fn src src-word-offset) (32bit-logical-or (shift-towards-start (funcall src-ref-fn src src-word-offset) src-bit-offset) (shift-towards-end (funcall src-ref-fn src (1+ src-word-offset)) (- src-bit-offset)))))) (t ;; We are only writing some portion of the dst word, so we need to ;; preserve the extra bits. Also, we still don't know if we need ;; one or two source words. (let ((mask (shift-towards-end (start-mask length) dst-bit-offset)) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (if (> src-bit-offset dst-bit-offset) ;; The source starts further into the word than does ;; the dst, so the source could extend into the next ;; word. If it does, we have to merge the two words, ;; and if not, we can just shift the first word. (let ((src-bit-shift (- src-bit-offset dst-bit-offset))) (if (> (+ src-bit-offset length) unit-bits) (32bit-logical-or (shift-towards-start (funcall src-ref-fn src src-word-offset) src-bit-shift) (shift-towards-end (funcall src-ref-fn src (1+ src-word-offset)) (- src-bit-shift))) (shift-towards-start (funcall src-ref-fn src src-word-offset) src-bit-shift))) ;; The dst starts further into the word than does the ;; source, so we know the source can't extend into ;; a second word (or else the dst would too, and we ;; wouldn't be in this branch). (shift-towards-end (funcall src-ref-fn src src-word-offset) (- dst-bit-offset src-bit-offset))))) (declare (type unit mask orig value)) ;; Replace the dst word. (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))))) ((= src-bit-offset dst-bit-offset) ;; The source and dst are aligned, so we don't need to shift ;; anything. But we have to pick the direction of the loop ;; in case the source and dst are really the same thing. (multiple-value-bind (words final-bits) (floor (+ dst-bit-offset length) unit-bits) (declare (type word-offset words) (type bit-offset final-bits)) (let ((interior (floor (- length final-bits) unit-bits))) (declare (type word-offset interior)) (cond ((<= dst-offset src-offset) ;; We need to loop from left to right (unless (zerop dst-bit-offset) ;; We are only writing part of the first word, so mask off the ;; bits we want to preserve. (let ((mask (end-mask (- dst-bit-offset))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))) (incf src-word-offset) (incf dst-word-offset)) ;; Just copy the interior words. (dotimes (i interior) (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)) (incf src-word-offset) (incf dst-word-offset)) (unless (zerop final-bits) ;; We are only writing part of the last word. (let ((mask (start-mask final-bits)) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))) (t ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset words) (unless (zerop final-bits) (let ((mask (start-mask final-bits)) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))) (dotimes (i interior) (decf src-word-offset) (decf dst-word-offset) (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))) (unless (zerop dst-bit-offset) (decf src-word-offset) (decf dst-word-offset) (let ((mask (end-mask (- dst-bit-offset))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))))) (t ;; They aren't aligned. (multiple-value-bind (words final-bits) (floor (+ dst-bit-offset length) unit-bits) (declare (type word-offset words) (type bit-offset final-bits)) (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits)) (interior (floor (- length final-bits) unit-bits))) (declare (type bit-offset src-shift) (type word-offset interior)) (cond ((<= dst-offset src-offset) ;; We need to loop from left to right (let ((prev 0) (next (funcall src-ref-fn src src-word-offset))) (declare (type unit prev next)) (flet ((get-next-src () (setf prev next) (setf next (funcall src-ref-fn src (incf src-word-offset))))) (declare (inline get-next-src)) (unless (zerop dst-bit-offset) (when (> src-bit-offset dst-bit-offset) (get-next-src)) (let ((mask (end-mask (- dst-bit-offset))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (32bit-logical-or (shift-towards-start prev src-shift) (shift-towards-end next (- src-shift))))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))) (incf dst-word-offset))) (dotimes (i interior) (get-next-src) (let ((value (32bit-logical-or (shift-towards-end next (- src-shift)) (shift-towards-start prev src-shift)))) (declare (type unit value)) (funcall dst-set-fn dst dst-word-offset value) (incf dst-word-offset))) (unless (zerop final-bits) (let ((value (if (> (+ final-bits src-shift) unit-bits) (progn (get-next-src) (32bit-logical-or (shift-towards-end next (- src-shift)) (shift-towards-start prev src-shift))) (shift-towards-start next src-shift))) (mask (start-mask final-bits)) (orig (funcall dst-ref-fn dst dst-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))) (t ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset (1- (ceiling (+ src-bit-offset length) unit-bits))) (let ((next 0) (prev (funcall src-ref-fn src src-word-offset))) (declare (type unit prev next)) (flet ((get-next-src () (setf next prev) (setf prev (funcall src-ref-fn src (decf src-word-offset))))) (declare (inline get-next-src)) (unless (zerop final-bits) (when (> final-bits (- unit-bits src-shift)) (get-next-src)) (let ((value (32bit-logical-or (shift-towards-end next (- src-shift)) (shift-towards-start prev src-shift))) (mask (start-mask final-bits)) (orig (funcall dst-ref-fn dst dst-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))) (decf dst-word-offset) (dotimes (i interior) (get-next-src) (let ((value (32bit-logical-or (shift-towards-end next (- src-shift)) (shift-towards-start prev src-shift)))) (declare (type unit value)) (funcall dst-set-fn dst dst-word-offset value) (decf dst-word-offset))) (unless (zerop dst-bit-offset) (if (> src-bit-offset dst-bit-offset) (get-next-src) (setf next prev prev 0)) (let ((mask (end-mask (- dst-bit-offset))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (32bit-logical-or (shift-towards-start prev src-shift) (shift-towards-end next (- src-shift))))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))))))))))))) (undefined-value)) ;;;; DO-UNARY-BYTE-BASH ;;;; Like DO-UNARY-BIT-BASH, but we only handle objects that are at ;;;; least byte in size. The offsets and lengths are byte offsets and ;;;; lengths, instead of bits. (declaim (inline do-unary-byte-bash)) (defun do-unary-byte-bash (src src-offset dst dst-offset length dst-ref-fn dst-set-fn src-ref-fn) (declare (type offset src-offset dst-offset length) (type function dst-ref-fn dst-set-fn src-ref-fn)) (multiple-value-bind (dst-word-offset dst-byte-offset) (floor dst-offset unit-bytes) (declare (type word-offset dst-word-offset) (type byte-offset dst-byte-offset)) (multiple-value-bind (src-word-offset src-byte-offset) (floor src-offset unit-bytes) (declare (type word-offset src-word-offset) (type byte-offset src-byte-offset)) (cond ((<= (+ dst-byte-offset length) unit-bytes) ;; We are only writing one word, so it doesn't matter what order ;; we do it in. But we might be reading from multiple words, so take ;; care. (cond ((zerop length) ;; Actually, we aren't even writing one word. This is real easy. ) ((= length unit-bytes) ;; dst-byte-offset must be equal to zero, or we would be writing ;; multiple words. If src-byte-offset is also zero, then we ;; just transfer the single word. Otherwise we have to extract bits ;; from two src words. (funcall dst-set-fn dst dst-word-offset (if (zerop src-byte-offset) (funcall src-ref-fn src src-word-offset) (32bit-logical-or (shift-towards-start (funcall src-ref-fn src src-word-offset) (* vm:byte-bits src-byte-offset)) (shift-towards-end (funcall src-ref-fn src (1+ src-word-offset)) (* vm:byte-bits (- src-byte-offset))))))) (t ;; We are only writing some portion of the dst word, so we need to ;; preserve the extra bits. Also, we still don't know if we need ;; one or two source words. (let ((mask (shift-towards-end (start-mask (* vm:byte-bits length)) (* vm:byte-bits dst-byte-offset))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (if (> src-byte-offset dst-byte-offset) ;; The source starts further into the word than does ;; the dst, so the source could extend into the next ;; word. If it does, we have to merge the two words, ;; and if not, we can just shift the first word. (let ((src-bit-shift (* vm:byte-bits (- src-byte-offset dst-byte-offset)))) (if (> (+ src-byte-offset length) unit-bytes) (32bit-logical-or (shift-towards-start (funcall src-ref-fn src src-word-offset) src-bit-shift) (shift-towards-end (funcall src-ref-fn src (1+ src-word-offset)) (- src-bit-shift))) (shift-towards-start (funcall src-ref-fn src src-word-offset) src-bit-shift))) ;; The dst starts further into the word than does the ;; source, so we know the source can't extend into ;; a second word (or else the dst would too, and we ;; wouldn't be in this branch). (shift-towards-end (funcall src-ref-fn src src-word-offset) (* vm:byte-bits (- dst-byte-offset src-byte-offset)))))) (declare (type unit mask orig value)) ;; Replace the dst word. (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))))) ((= src-byte-offset dst-byte-offset) ;; The source and dst are aligned, so we don't need to shift ;; anything. But we have to pick the direction of the loop ;; in case the source and dst are really the same thing. (multiple-value-bind (words final-bytes) (floor (+ dst-byte-offset length) unit-bytes) (declare (type word-offset words) (type byte-offset final-bytes)) (let ((interior (floor (- length final-bytes) unit-bytes))) (declare (type word-offset interior)) (cond ((<= dst-offset src-offset) ;; We need to loop from left to right (unless (zerop dst-byte-offset) ;; We are only writing part of the first word, so mask off the ;; bits we want to preserve. (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))) (incf src-word-offset) (incf dst-word-offset)) ;; Just copy the interior words. (dotimes (i interior) (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)) (incf src-word-offset) (incf dst-word-offset)) (unless (zerop final-bytes) ;; We are only writing part of the last word. (let ((mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))) (t ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset words) (unless (zerop final-bytes) (let ((mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))) (dotimes (i interior) (decf src-word-offset) (decf dst-word-offset) (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))) (unless (zerop dst-byte-offset) (decf src-word-offset) (decf dst-word-offset) (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))))) (t ;; They aren't aligned. (multiple-value-bind (words final-bytes) (floor (+ dst-byte-offset length) unit-bytes) (declare (type word-offset words) (type byte-offset final-bytes)) (let ((src-shift (mod (- src-byte-offset dst-byte-offset) unit-bytes)) (interior (floor (- length final-bytes) unit-bytes))) (declare (type byte-offset src-shift) (type word-offset interior)) (cond ((<= dst-offset src-offset) ;; We need to loop from left to right (let ((prev 0) (next (funcall src-ref-fn src src-word-offset))) (declare (type unit prev next)) (flet ((get-next-src () (setf prev next) (setf next (funcall src-ref-fn src (incf src-word-offset))))) (declare (inline get-next-src)) (unless (zerop dst-byte-offset) (when (> src-byte-offset dst-byte-offset) (get-next-src)) (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (32bit-logical-or (shift-towards-start prev (* vm:byte-bits src-shift)) (shift-towards-end next (* vm:byte-bits (- src-shift)))))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))) (incf dst-word-offset))) (dotimes (i interior) (get-next-src) (let ((value (32bit-logical-or (shift-towards-end next (* vm:byte-bits (- src-shift))) (shift-towards-start prev (* vm:byte-bits src-shift))))) (declare (type unit value)) (funcall dst-set-fn dst dst-word-offset value) (incf dst-word-offset))) (unless (zerop final-bytes) (let ((value (if (> (+ final-bytes src-shift) unit-bytes) (progn (get-next-src) (32bit-logical-or (shift-towards-end next (* vm:byte-bits (- src-shift))) (shift-towards-start prev (* vm:byte-bits src-shift)))) (shift-towards-start next (* vm:byte-bits src-shift)))) (mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))) (t ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset (1- (ceiling (+ src-byte-offset length) unit-bytes))) (let ((next 0) (prev (funcall src-ref-fn src src-word-offset))) (declare (type unit prev next)) (flet ((get-next-src () (setf next prev) (setf prev (funcall src-ref-fn src (decf src-word-offset))))) (declare (inline get-next-src)) (unless (zerop final-bytes) (when (> final-bytes (- unit-bytes src-shift)) (get-next-src)) (let ((value (32bit-logical-or (shift-towards-end next (* vm:byte-bits (- src-shift))) (shift-towards-start prev (* vm:byte-bits src-shift)))) (mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))) (decf dst-word-offset) (dotimes (i interior) (get-next-src) (let ((value (32bit-logical-or (shift-towards-end next (* vm:byte-bits (- src-shift))) (shift-towards-start prev (* vm:byte-bits src-shift))))) (declare (type unit value)) (funcall dst-set-fn dst dst-word-offset value) (decf dst-word-offset))) (unless (zerop dst-byte-offset) (if (> src-byte-offset dst-byte-offset) (get-next-src) (setf next prev prev 0)) (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (32bit-logical-or (shift-towards-start prev (* vm:byte-bits src-shift)) (shift-towards-end next (* vm:byte-bits (- src-shift)))))) (declare (type unit mask orig value)) (funcall dst-set-fn dst dst-word-offset (32bit-logical-or (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))))))))))))) (undefined-value)) ;;;; The actual bashers. (defun bit-bash-fill (value dst dst-offset length) (declare (type unit value) (type offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0))) (do-constant-bit-bash dst dst-offset length value #'%raw-bits #'%set-raw-bits))) (defun system-area-fill (value dst dst-offset length) (declare (type unit value) (type offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset) (do-constant-bit-bash dst dst-offset length value #'word-sap-ref #'%set-word-sap-ref)))) (defun bit-bash-copy (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0)) (inline do-unary-bit-bash)) (do-unary-bit-bash src src-offset dst dst-offset length #'%raw-bits #'%set-raw-bits #'%raw-bits))) (defun byte-bash-copy (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0)) (inline do-unary-bit-bash)) (do-unary-byte-bash src src-offset dst dst-offset length #'%raw-bits #'%set-raw-bits #'%raw-bits))) (defun system-area-copy (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset) (declare (type system-area-pointer src)) (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset) (declare (type system-area-pointer dst)) (do-unary-bit-bash src src-offset dst dst-offset length #'word-sap-ref #'%set-word-sap-ref #'word-sap-ref))))) (defun copy-to-system-area (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset) (do-unary-bit-bash src src-offset dst dst-offset length #'word-sap-ref #'%set-word-sap-ref #'%raw-bits)))) (defun copy-from-system-area (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset) (do-unary-bit-bash src src-offset dst dst-offset length #'%raw-bits #'%set-raw-bits #'word-sap-ref)))) cmucl-21a/src/code/bsd-os.lisp000066400000000000000000000055661260377556400163560ustar00rootroot00000000000000;;; -*- Package: SYSTEM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/bsd-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMU CL under BSD Unix. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. ;;; ;;; Hacked into (Free)bsd-os.lisp by Paul Werkowski. ;;; Generalized a bit for OpenBSD by Pierre R. Mai. ;;; Support for NetBSD by Pierre R. Mai. ;;; Support for Darwin by Pierre R. Mai. (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl-bsd-os") (export '(get-system-info get-page-size os-init)) (register-lisp-feature :bsd) (register-lisp-feature #+OpenBSD :OpenBSD #+NetBSD :NetBSD #+freebsd :freebsd #+Darwin :Darwin #-(or freebsd NetBSD OpenBSD Darwin) :bsd) #+elf (register-lisp-runtime-feature :elf) #+mach-o (register-lisp-runtime-feature :mach-o) #+executable (register-lisp-runtime-feature :executable) (setq *software-type* #+OpenBSD "OpenBSD" #+NetBSD "NetBSD" #+freebsd "FreeBSD" #+Darwin "Darwin" #-(or freebsd NetBSD OpenBSD Darwin) "BSD") (defvar *software-version* nil "Version string for supporting software") (defun software-version () "Returns a string describing version of the supporting software." (unless *software-version* (setf *software-version* (string-trim '(#\newline) (with-output-to-string (stream) (run-program "/usr/bin/uname" '("-r") :output stream))))) *software-version*) ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions ;;; that set up the argument blocks for the server interfaces. (defun os-init () (setf *software-version* nil)) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (unless err? (error (intl:gettext "Unix system call getrusage failed: ~A.") (unix:get-unix-error-msg utime))) (values utime stime majflt))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (multiple-value-bind (val err) (unix:unix-getpagesize) (unless val (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err))) val)) cmucl-21a/src/code/byte-interp.lisp000066400000000000000000001421421260377556400174210ustar00rootroot00000000000000;;; -*- Package: C -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/byte-interp.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the noise to interpret byte-compiled stuff. ;;; ;;; Written by William Lott ;;; (in-package "C") (in-package "KERNEL") (intl:textdomain "cmucl") (export '(byte-function byte-function-name initialize-byte-compiled-function byte-closure byte-closure-function byte-closure-data byte-function-or-closure byte-function-type *eval-stack* *eval-stack-top*)) (in-package "C") ;;; We need at least this level of debug-info in order for the local ;;; declaration in with-debugger-info to take effect. ;;; (declaim (optimize (debug 2))) ;;;; Types. (deftype stack-pointer () `(integer 0 ,(1- most-positive-fixnum))) (defconstant max-pc (1- (ash 1 24))) (deftype pc () `(integer 0 ,max-pc)) (deftype return-pc () `(integer ,(- max-pc) ,max-pc)) ;;; These dummies are defined here, to make a build without compiler ;;; work. (defun %dynamic-extent (kind sp) (declare (ignore kind sp))) (defun %dynamic-extent-start ()) (defun %dynamic-extent-end (kind sp) (declare (ignore kind sp))) ;;;; Byte functions: ;;; Abstract class represents any type of byte-compiled function. ;;; (defstruct (byte-function-or-closure (:alternate-metaclass kernel:funcallable-instance kernel:funcallable-structure-class kernel:make-funcallable-structure-class) (:type kernel:funcallable-structure))) ;;; Represents a byte-compiled closure. ;;; (defstruct (byte-closure (:include byte-function-or-closure) (:constructor make-byte-closure (function data)) (:type kernel:funcallable-structure) (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t) (format stream "Byte closure ~S" (byte-function-name (byte-closure-function s))))))) ;; ;; Byte function that we call. (function (required-argument) :type byte-function) ;; ;; Closure data vector. (data (required-argument) :type simple-vector)) ;;; Any non-closure byte function (including the hidden function object for a ;;; closure.) ;;; (defstruct (byte-function (:include byte-function-or-closure) (:print-function %print-byte-function) (:type kernel:funcallable-structure)) ;; ;; The component that this XEP is an entry point into. NIL until ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this being ;; the first slot. (component nil :type (or null kernel:code-component)) ;; ;; Debug name of this function. (name nil)) ;;; Fixed-argument byte function. ;;; (defstruct (simple-byte-function (:include byte-function) (:type kernel:funcallable-structure)) ;; ;; The number of arguments expected. (num-args 0 :type (integer 0 #.call-arguments-limit)) ;; ;; The start of the function. (entry-point 0 :type index)) ;;; Variable arg-count byte function. ;;; (defstruct (hairy-byte-function (:include byte-function) (:type kernel:funcallable-structure)) ;; ;; The minimum and maximum number of args, ignoring &rest and &key. (min-args 0 :type (integer 0 #.call-arguments-limit)) (max-args 0 :type (integer 0 #.call-arguments-limit)) ;; ;; List of the entry points for min-args, min-args+1, ... max-args. (entry-points nil :type list) ;; ;; The entry point to use when there are more than max-args. Only filled ;; in where okay. In other words, only when &rest or &key is specified. (more-args-entry-point nil :type (or null (unsigned-byte 24))) ;; ;; The number of ``more-arg'' args. (num-more-args 0 :type (integer 0 #.call-arguments-limit)) ;; ;; True if there is a rest-arg, :MORE if there is &MORE. (rest-arg-p nil :type (member t nil :more)) ;; ;; True if there are keywords. Note: keywords might still be NIL because ;; having &key with no keywords is valid and should result in ;; allow-other-keys processing. If :allow-others, then allow other keys. (keywords-p nil :type (member t nil :allow-others)) ;; ;; List of keyword arguments. Each element is a list of: ;; key, default, supplied-p. (keywords nil :type list)) (defun %print-byte-function (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t) (format stream "Byte function ~S" (byte-function-name s)))) (declaim (freeze-type byte-function-or-closure)) ;;; BYTE-FUNCTION-TYPE -- Interface ;;; ;;; Return a function type approximating the type of a byte compiled ;;; function. We really only capture the arg signature. ;;; (defun byte-function-type (x) (specifier-type (etypecase x (simple-byte-function `(function ,(make-list (simple-byte-function-num-args x) :initial-element 't) *)) (hairy-byte-function (collect ((res)) (let ((min (hairy-byte-function-min-args x)) (max (hairy-byte-function-max-args x))) (dotimes (i min) (res 't)) (when (> max min) (res '&optional) (dotimes (i (- max min)) (res 't)))) (when (hairy-byte-function-rest-arg-p x) (res '&rest 't)) (ecase (hairy-byte-function-keywords-p x) ((t :allow-others) (res '&key) (dolist (key (hairy-byte-function-keywords x)) (res `(,(car key) t))) (if (eql (hairy-byte-function-keywords-p x) :allow-others) (res '&allow-other-keys))) ((nil))) `(function ,(res) *)))))) ;;;; The stack. (defvar *eval-stack* (make-array 100) "This is the interpreter's evaluation stack.") (declaim (type simple-vector *eval-stack*)) (defvar *eval-stack-top* 0 "This is the next free element of the interpreter's evaluation stack.") (declaim (type index *eval-stack-top*)) (defmacro current-stack-pointer () '*eval-stack-top*) (declaim (inline eval-stack-ref)) (defun eval-stack-ref (offset) (declare (type stack-pointer offset)) (svref eval::*eval-stack* offset)) (declaim (inline (setf eval-stack-ref))) (defun (setf eval-stack-ref) (new-value offset) (declare (type stack-pointer offset)) (setf (svref eval::*eval-stack* offset) new-value)) (defun push-eval-stack (value) (let ((len (length (the simple-vector eval::*eval-stack*))) (sp (current-stack-pointer))) (when (= len sp) (let ((new-stack (make-array (ash len 1)))) (replace new-stack eval::*eval-stack* :end1 len :end2 len) (setf eval::*eval-stack* new-stack))) (setf (current-stack-pointer) (1+ sp)) (setf (eval-stack-ref sp) value))) (defun allocate-eval-stack (amount) (let* ((len (length (the simple-vector eval::*eval-stack*))) (sp (current-stack-pointer)) (new-sp (+ sp amount))) (declare (type index sp new-sp)) (when (>= new-sp len) (let ((new-stack (make-array (ash new-sp 1)))) (replace new-stack eval::*eval-stack* :end1 len :end2 len) (setf eval::*eval-stack* new-stack))) (setf (current-stack-pointer) new-sp) (let ((stack eval::*eval-stack*)) (do ((i sp (1+ i))) ((= i new-sp)) (setf (svref stack i) '#:uninitialized)))) (undefined-value)) (defun pop-eval-stack () (let* ((new-sp (1- (current-stack-pointer))) (value (eval-stack-ref new-sp))) (setf (current-stack-pointer) new-sp) value)) (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body) (declare (optimize (inhibit-warnings 3))) (let ((num-vars (length vars)) (index -1) (new-sp-var (gensym "NEW-SP-")) (decls nil)) (loop (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare)) (return)) (push (pop body) decls)) `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars))) (declare (type stack-pointer ,new-sp-var)) (let ,(mapcar #'(lambda (var) `(,var (eval-stack-ref (+ ,new-sp-var ,(incf index))))) vars) ,@(nreverse decls) (setf (current-stack-pointer) ,new-sp-var) ,@body)))) (defun stack-copy (dest src count) (declare (type stack-pointer dest src count)) (let ((stack *eval-stack*)) (if (< dest src) (dotimes (i count) (setf (svref stack dest) (svref stack src)) (incf dest) (incf src)) (do ((si (1- (+ src count)) (1- si)) (di (1- (+ dest count)) (1- di))) ((< si src)) (declare (fixnum si di)) (setf (svref stack di) (svref stack si))))) (undefined-value)) ;;;; Component access magic. (declaim (inline component-ref)) (defun component-ref (component pc) (declare (type code-component component) (type pc pc)) (system:sap-ref-8 (code-instructions component) pc)) (declaim (inline (setf component-ref))) (defun (setf component-ref) (value component pc) (declare (type (unsigned-byte 8) value) (type code-component component) (type pc pc)) (setf (system:sap-ref-8 (code-instructions component) pc) value)) (declaim (inline component-ref-signed)) (defun component-ref-signed (component pc) (let ((byte (component-ref component pc))) (if (logbitp 7 byte) (logior (ash -1 8) byte) byte))) (declaim (inline component-ref-24)) (defun component-ref-24 (component pc) (logior (ash (component-ref component pc) 16) (ash (component-ref component (1+ pc)) 8) (component-ref component (+ pc 2)))) ;;;; Debugging support. ;;; WITH-DEBUGGER-INFO -- internal. ;;; ;;; This macro binds three magic variables. When the debugger notices that ;;; these three variables are bound, it makes a byte-code frame out of the ;;; supplied information instead of a compiled frame. We set each var in ;;; addition to binding it so the compiler doesn't optimize away the binding. ;;; (defmacro with-debugger-info ((component pc fp) &body body) `(let ((%byte-interp-component ,component) (%byte-interp-pc ,pc) (%byte-interp-fp ,fp)) (declare (optimize (debug 3))) (setf %byte-interp-component %byte-interp-component) (setf %byte-interp-pc %byte-interp-pc) (setf %byte-interp-fp %byte-interp-fp) ,@body)) (defun byte-install-breakpoint (component pc) (declare (type code-component component) (type pc pc) (values (unsigned-byte 8))) (let ((orig (component-ref component pc))) (setf (component-ref component pc) #.(logior byte-xop (xop-index-or-lose 'breakpoint))) orig)) (defun byte-remove-breakpoint (component pc orig) (declare (type code-component component) (type pc pc) (type (unsigned-byte 8) orig) (values (unsigned-byte 8))) (setf (component-ref component pc) orig)) (defun byte-skip-breakpoint (component pc fp orig) (declare (type code-component component) (type pc pc) (type stack-pointer fp) (type (unsigned-byte 8) orig)) (byte-interpret-byte component fp pc orig)) ;;;; System constants ;;; A table mapping system constant indices to run-time values. We don't ;;; reference the compiler variable at load time, since the interpreter is ;;; loaded first. ;;; (defparameter system-constants (let ((res (make-array 256))) (dolist (x '#.(collect ((res)) (do-hash (key value *system-constant-codes*) (res (cons key value))) (res))) (let ((key (car x)) (value (cdr x))) (setf (svref res value) (if (and (consp key) (eq (car key) '%fdefinition-marker%)) (lisp::fdefinition-object (cdr key) t) key)))) res)) ;;;; Byte compiled function constructors/extractors. (defun initialize-byte-compiled-function (xep) (declare (type byte-function xep)) (push xep (code-header-ref (byte-function-component xep) vm:code-trace-table-offset-slot)) (setf (funcallable-instance-function xep) #'(instance-lambda (&more context count) (let ((old-sp (current-stack-pointer))) (declare (type stack-pointer old-sp)) (dotimes (i count) (push-eval-stack (%more-arg context i))) (invoke-xep nil 0 old-sp 0 count xep)))) xep) (defun make-byte-compiled-closure (xep closure-vars) (declare (type byte-function xep) (type simple-vector closure-vars)) (let ((res (make-byte-closure xep closure-vars))) (setf (funcallable-instance-function res) #'(instance-lambda (&more context count) (let ((old-sp (current-stack-pointer))) (declare (type stack-pointer old-sp)) (dotimes (i count) (push-eval-stack (%more-arg context i))) (invoke-xep nil 0 old-sp 0 count (byte-closure-function res) (byte-closure-data res))))) res)) ;;;; Inlines. (eval-when (compile eval) (setq ext:*inline-expansion-limit* 400)) (defmacro expand-into-inlines () (declare (optimize (inhibit-warnings 3))) (iterate build-dispatch ((bit 4) (base 0)) (if (minusp bit) (let ((info (svref *inline-functions* base))) (if info (let* ((spec (type-specifier (inline-function-info-type info))) (arg-types (second spec)) (result-type (third spec)) (args (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) arg-types)) (func `(the ,result-type (,(inline-function-info-interpreter-function info) ,@args)))) `(multiple-value-pop-eval-stack ,args (declare ,@(mapcar #'(lambda (type var) `(type ,type ,var)) arg-types args)) ,(if (and (consp result-type) (eq (car result-type) 'values)) (let ((results (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr result-type)))) `(multiple-value-bind ,results ,func ,@(mapcar #'(lambda (res) `(push-eval-stack ,res)) results))) `(push-eval-stack ,func)))) `(error (intl:gettext "Unknown inline function, id=~D") ,base))) `(if (zerop (logand byte ,(ash 1 bit))) ,(build-dispatch (1- bit) base) ,(build-dispatch (1- bit) (+ base (ash 1 bit))))))) (declaim (inline value-cell-setf)) (defun value-cell-setf (value cell) (value-cell-set cell value) value) (declaim (inline setf-symbol-value)) (defun setf-symbol-value (value symbol) (setf (symbol-value symbol) value)) (declaim (inline %setf-instance-ref)) (defun %setf-instance-ref (new-value instance index) (setf (%instance-ref instance index) new-value)) (eval-when (compile) (defmacro %byte-symbol-value (x) `(let ((x ,x)) (unless (boundp x) (with-debugger-info (component pc fp) (error (intl:gettext "Unbound variable: ~S") x))) (symbol-value x))) (defmacro %byte-car (x) `(let ((x ,x)) (unless (listp x) (with-debugger-info (component pc fp) (error 'simple-type-error :datum x :expected-type 'list :format-control (intl:gettext "Non-list argument to CAR: ~S") :format-arguments (list x)))) (car x))) (defmacro %byte-cdr (x) `(let ((x ,x)) (unless (listp x) (with-debugger-info (component pc fp) (error 'simple-type-error :datum x :expected-type 'list :format-control (intl:gettext "Non-list argument to CDR: ~S") :format-arguments (list x)))) (cdr x))) ); eval-when (compile) (declaim (inline %byte-special-bind)) (defun %byte-special-bind (value symbol) (system:%primitive bind value symbol) (values)) (declaim (inline %byte-special-unbind)) (defun %byte-special-unbind () (system:%primitive unbind) (values)) ;;; obsolete... (declaim (inline cons-unique-tag)) (defun cons-unique-tag () (list '#:%unique-tag%)) ;;;; Two-arg function stubs: ;;; ;;; We have two-arg versions of some n-ary functions that are normally ;;; open-coded. (defun two-arg-char= (x y) (char= x y)) (defun two-arg-char< (x y) (char< x y)) (defun two-arg-char> (x y) (char> x y)) (defun two-arg-char-equal (x y) (char-equal x y)) (defun two-arg-char-lessp (x y) (char-lessp x y)) (defun two-arg-char-greaterp (x y) (char-greaterp x y)) (defun two-arg-string= (x y) (string= x y)) (defun two-arg-string< (x y) (string< x y)) (defun two-arg-string> (x y) (string> x y)) ;;;; Misc primitive stubs: (macrolet ((frob (name &optional (args '(x))) `(defun ,name ,args (,name ,@args)))) (frob %CODE-CODE-SIZE) (frob %CODE-DEBUG-INFO) (frob %CODE-ENTRY-POINTS) (frob %FUNCALLABLE-INSTANCE-FUNCTION) (frob %FUNCALLABLE-INSTANCE-LAYOUT) (frob %FUNCALLABLE-INSTANCE-LEXENV) (frob %FUNCTION-NEXT) (frob %FUNCTION-SELF) (frob %SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-val)) (frob %SXHASH-SIMPLE-SUBSTRING (str count))) ;;;; Funny functions: ;;; used by both byte and IR1 interpreters. ;;; (defun %progv (vars vals fun) (progv vars vals (funcall fun))) ;;;; XOPs ;;; Extension operations (XOPs) are random magic things that the byte ;;; interpreter needs to do, but can't be represented as a function call. ;;; When the byte interpreter encounters an XOP in the byte stream, it ;;; tail-calls the corresponding XOP routine extracted from *byte-xops*. ;;; The XOP routine can do whatever it wants, probably re-invoking the ;;; byte interpreter. ;;; Fetch an 8/24 bit operand out of the code stream. ;;; (eval-when (compile eval) (defmacro with-extended-operand ((component pc operand new-pc) &body body) (once-only ((n-component component) (n-pc pc)) `(multiple-value-bind (,operand ,new-pc) (let ((,operand (component-ref ,n-component ,n-pc))) (if (= ,operand #xff) (values (component-ref-24 ,n-component (1+ ,n-pc)) (+ ,n-pc 4)) (values ,operand (1+ ,n-pc)))) (declare (type index ,operand ,new-pc)) ,@body)))) ;;; UNDEFINED-XOP -- internal. ;;; ;;; If a real XOP hasn't been defined, this gets invoked and signals an ;;; error. This shouldn't happen in normal operation. ;;; (defun undefined-xop (component old-pc pc fp) (declare (ignore component old-pc pc fp)) (error (intl:gettext "Undefined XOP."))) ;;; *BYTE-XOPS* -- Simple vector of the XOP functions. ;;; (declaim (type (simple-vector 256) *byte-xops*)) (defvar *byte-xops* (make-array 256 :initial-element #'undefined-xop)) ;;; DEFINE-XOP -- internal. ;;; ;;; Define a XOP function and install it in *BYTE-XOPS*. ;;; (eval-when (compile eval) (defmacro define-xop (name lambda-list &body body) (let ((defun-name (symbolicate "BYTE-" name "-XOP"))) `(progn (defun ,defun-name ,lambda-list ,@body) (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name) ',defun-name)))) ;;; BREAKPOINT -- Xop. ;;; ;;; This is spliced in by the debugger in order to implement breakpoints. ;;; (define-xop breakpoint (component old-pc pc fp) (declare (type code-component component) (type pc old-pc) (ignore pc) (type stack-pointer fp)) ;; Invoke the debugger. (with-debugger-info (component old-pc fp) (di::handle-breakpoint component old-pc fp)) ;; Retry the breakpoint XOP in case it was replaced with the original ;; displaced byte-code. (byte-interpret component old-pc fp)) ;;; DUP -- Xop. ;;; ;;; This just duplicates whatever is on the top of the stack. ;;; (define-xop dup (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let ((value (eval-stack-ref (1- (current-stack-pointer))))) (push-eval-stack value)) (byte-interpret component pc fp)) ;;; MAKE-CLOSURE -- Xop. ;;; (define-xop make-closure (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let* ((num-closure-vars (pop-eval-stack)) (closure-vars (make-array num-closure-vars))) (declare (type index num-closure-vars) (type simple-vector closure-vars)) (iterate frob ((index (1- num-closure-vars))) (unless (minusp index) (setf (svref closure-vars index) (pop-eval-stack)) (frob (1- index)))) (push-eval-stack (make-byte-compiled-closure (pop-eval-stack) closure-vars))) (byte-interpret component pc fp)) (define-xop merge-unknown-values (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (labels ((grovel (remaining-blocks block-count-ptr) (declare (type index remaining-blocks) (type stack-pointer block-count-ptr)) (declare (values index stack-pointer)) (let ((block-count (eval-stack-ref block-count-ptr))) (declare (type index block-count)) (if (= remaining-blocks 1) (values block-count block-count-ptr) (let ((src (- block-count-ptr block-count))) (declare (type index src)) (multiple-value-bind (values-above dst) (grovel (1- remaining-blocks) (1- src)) (stack-copy dst src block-count) (values (+ values-above block-count) (+ dst block-count)))))))) (multiple-value-bind (total-count end-ptr) (grovel (pop-eval-stack) (1- (current-stack-pointer))) (setf (eval-stack-ref end-ptr) total-count) (setf (current-stack-pointer) (1+ end-ptr)))) (byte-interpret component pc fp)) (define-xop default-unknown-values (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let* ((desired (pop-eval-stack)) (supplied (pop-eval-stack)) (delta (- desired supplied))) (declare (type index desired supplied) (type fixnum delta)) (cond ((minusp delta) (incf (current-stack-pointer) delta)) ((plusp delta) (dotimes (i delta) (push-eval-stack nil))))) (byte-interpret component pc fp)) ;;; THROW -- XOP ;;; ;;; %THROW is compiled down into this xop. The stack contains the tag, the ;;; values, and then a count of the values. We special case various small ;;; numbers of values to keep from consing if we can help it. ;;; ;;; Basically, we just extract the values and the tag and then do a throw. ;;; The native compiler will convert this throw into whatever is necessary ;;; to throw, so we don't have to duplicate all that cruft. ;;; (define-xop throw (component old-pc pc fp) (declare (type code-component component) (type pc old-pc) (ignore pc) (type stack-pointer fp)) (let ((num-results (pop-eval-stack))) (declare (type index num-results)) (case num-results (0 (let ((tag (pop-eval-stack))) (with-debugger-info (component old-pc fp) (throw tag (values))))) (1 (multiple-value-pop-eval-stack (tag result) (with-debugger-info (component old-pc fp) (throw tag result)))) (2 (multiple-value-pop-eval-stack (tag result0 result1) (with-debugger-info (component old-pc fp) (throw tag (values result0 result1))))) (t (let ((results nil)) (dotimes (i num-results) (push (pop-eval-stack) results)) (let ((tag (pop-eval-stack))) (with-debugger-info (component old-pc fp) (throw tag (values-list results))))))))) ;;; CATCH -- XOP ;;; ;;; This is used for both CATCHes and BLOCKs that are closed over. We ;;; establish a catcher for the supplied tag (from the stack top), and ;;; recursivly enter the byte interpreter. If the byte interpreter exits, ;;; it must have been because of a BREAKUP (see below), so we branch (by ;;; tail-calling the byte interpreter) to the pc returned by BREAKUP. ;;; If we are thrown to, then we branch to the address encoded in the 3 bytes ;;; following the catch XOP. ;;; (define-xop catch (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let ((new-pc (block nil (let ((results (multiple-value-list (catch (pop-eval-stack) (return (byte-interpret component (+ pc 3) fp)))))) (let ((num-results 0)) (declare (type index num-results)) (dolist (result results) (push-eval-stack result) (incf num-results)) (push-eval-stack num-results)) (component-ref-24 component pc))))) (byte-interpret component new-pc fp))) ;;; BREAKUP -- XOP ;;; ;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the ;;; pc following the BREAKUP XOP and the drop-through code in CATCH or ;;; TAGBODY will do the correct thing. ;;; (define-xop breakup (component old-pc pc fp) (declare (ignore component old-pc fp) (type pc pc)) pc) ;;; RETURN-FROM -- XOP ;;; ;;; This is exactly like THROW, except that the tag is the last thing on ;;; the stack instead of the first. This is used for RETURN-FROM (hence the ;;; name). ;;; (define-xop return-from (component old-pc pc fp) (declare (type code-component component) (type pc old-pc) (ignore pc) (type stack-pointer fp)) (let ((tag (pop-eval-stack)) (num-results (pop-eval-stack))) (declare (type index num-results)) (case num-results (0 (with-debugger-info (component old-pc fp) (throw tag (values)))) (1 (let ((value (pop-eval-stack))) (with-debugger-info (component old-pc fp) (throw tag value)))) (2 (multiple-value-pop-eval-stack (result0 result1) (with-debugger-info (component old-pc fp) (throw tag (values result0 result1))))) (t (let ((results nil)) (dotimes (i num-results) (push (pop-eval-stack) results)) (with-debugger-info (component old-pc fp) (throw tag (values-list results)))))))) ;;; TAGBODY -- XOP ;;; ;;; Similar to CATCH, except for TAGBODY. One significant difference is that ;;; when thrown to, we don't want to leave the dynamic extent of the tagbody ;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP ;;; is used to blow out. When that happens, we just branch to the pc supplied ;;; by BREAKUP. ;;; (define-xop tagbody (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let* ((tag (pop-eval-stack)) (new-pc (block nil (loop (setf pc (catch tag (return (byte-interpret component pc fp)))))))) (byte-interpret component new-pc fp))) ;;; GO -- XOP ;;; ;;; Yup, you guessed it. This XOP implements GO. There are no values to ;;; pass, so we don't have to mess with them, and multiple exits can all be ;;; using the same tag so we have to pass the pc we want to go to. ;;; (define-xop go (component old-pc pc fp) (declare (type code-component component) (type pc old-pc pc) (type stack-pointer fp)) (let ((tag (pop-eval-stack)) (new-pc (component-ref-24 component pc))) (with-debugger-info (component old-pc fp) (throw tag new-pc)))) ;;; UNWIND-PROTECT -- XOP ;;; ;;; Unwind-protects are handled significantly differently in the byte compiler ;;; and the native compiler. Basically, we just use the native-compiler's ;;; unwind-protect, and let it worry about continuing the unwind. ;;; (define-xop unwind-protect (component old-pc pc fp) (declare (type code-component component) (ignore old-pc) (type pc pc) (type stack-pointer fp)) (let ((new-pc nil)) (unwind-protect (setf new-pc (byte-interpret component (+ pc 3) fp)) (unless new-pc ;; The cleanup function expects 3 values to be one the stack, so ;; we have to put something there. (push-eval-stack nil) (push-eval-stack nil) (push-eval-stack nil) ;; Now run the cleanup code. (byte-interpret component (component-ref-24 component pc) fp))) (byte-interpret component new-pc fp))) (define-xop fdefn-function-or-lose (component old-pc pc fp) (let* ((fdefn (pop-eval-stack)) (fun (fdefn-function fdefn))) (declare (type fdefn fdefn)) (cond (fun (push-eval-stack fun) (byte-interpret component pc fp)) (t (with-debugger-info (component old-pc fp) (error 'undefined-function :name (fdefn-name fdefn))))))) ;;; Used to insert placeholder arguments for unused arguments to local calls. ;;; (define-xop push-n-under (component old-pc pc fp) (declare (ignore old-pc)) (with-extended-operand (component pc howmany new-pc) (let ((val (pop-eval-stack))) (allocate-eval-stack howmany) (push-eval-stack val)) (byte-interpret component new-pc fp))) ;;;; Type checking: ;;; ;;; These two hash tables map between type specifiers and type predicate ;;; functions that test those types. They are initialized according to the ;;; standard type predicates of the target system. ;;; (defvar *byte-type-predicates* (make-hash-table :test #'equal)) (defvar *byte-predicate-types* (make-hash-table :test #'eq)) (loop for (type predicate) in '#.(loop for (type . predicate) in (backend-type-predicates *target-backend*) collect `(,(type-specifier type) ,predicate)) do (let ((fun (fdefinition predicate))) (setf (gethash type *byte-type-predicates*) fun) (setf (gethash fun *byte-predicate-types*) type))) ;;; LOAD-TYPE-PREDICATE -- Internal ;;; ;;; Called by the loader to convert a type specifier into a type predicate ;;; (as used by the TYPE-CHECK XOP). If it is a structure type with a ;;; predicate or has a predefined predicate, then return the predicate ;;; function, otherwise return the CTYPE structure for the type. ;;; (defun load-type-predicate (desc) (or (gethash desc *byte-type-predicates*) (let ((type (specifier-type desc))) (if (typep type 'kernel::structure-class) (let ((info (layout-info (%class-layout type)))) (if (and info (eq (dd-type info) 'structure)) (let ((pred (dd-predicate info))) (if (and pred (fboundp pred)) (fdefinition pred) type)) type)) type)))) ;;; TYPE-CHECK -- Xop. ;;; ;;; Check the type of the value on the top of the stack. The type is ;;; designated by an entry in the constants. If the value is a function, then ;;; it is called as a type predicate. Otherwise, the value is a CTYPE object, ;;; and we call %TYPEP on it. ;;; (define-xop type-check (component old-pc pc fp) (declare (type code-component component) (type pc old-pc pc) (type stack-pointer fp)) (with-extended-operand (component pc operand new-pc) (let ((value (eval-stack-ref (1- (current-stack-pointer)))) (type (code-header-ref component (+ operand vm:code-constants-offset)))) (unless (if (functionp type) (funcall type value) (%typep value type)) (with-debugger-info (component old-pc fp) (error 'type-error :datum value :expected-type (if (functionp type) (gethash type *byte-predicate-types*) (type-specifier type)))))) (byte-interpret component new-pc fp))) ;;;; The byte-interpreter. ;;; The various operations are encoded as follows. ;;; ;;; 0000xxxx push-local op ;;; 0001xxxx push-arg op [push-local, but negative] ;;; 0010xxxx push-constant op ;;; 0011xxxx push-system-constant op ;;; 0100xxxx push-int op ;;; 0101xxxx push-neg-int op ;;; 0110xxxx pop-local op ;;; 0111xxxx pop-n op ;;; 1000nxxx call op ;;; 1001nxxx tail-call op ;;; 1010nxxx multiple-call op ;;; 10110xxx local-call ;;; 10111xxx local-tail-call ;;; 11000xxx local-multiple-call ;;; 11001xxx return ;;; 1101000r branch ;;; 1101001r if-true ;;; 1101010r if-false ;;; 1101011r if-eq ;;; 11011xxx Xop ;;; 11100000 ;;; to various inline functions. ;;; 11111111 ;;; ;;; This encoding is rather hard wired into BYTE-INTERPRET due to the binary ;;; dispatch tree. ;;; (declaim (start-block byte-interpret byte-interpret-byte invoke-xep invoke-local-entry-point)) (defvar *byte-trace* nil) ;;; BYTE-INTERPRET -- Internal Interface. ;;; ;;; Main entry point to the byte interpreter. ;;; (defun byte-interpret (component pc fp) (declare (type code-component component) (type pc pc) (type stack-pointer fp)) (byte-interpret-byte component pc fp (component-ref component pc))) ;;; BYTE-INTERPRET-BYTE -- Internal. ;;; ;;; This is seperated from BYTE-INTERPRET so we can continue from a breakpoint ;;; without having to replace the breakpoint with the original instruction ;;; and arrange to somehow put the breakpoint back after executing the ;;; instruction. We just leave the breakpoint there, and calls this function ;;; with the byte the breakpoint displaced. ;;; (defun byte-interpret-byte (component pc fp byte) (declare (type code-component component) (type pc pc) (type stack-pointer fp) (type (unsigned-byte 8) byte) (optimize (speed 3) (safety 0))) #+nil (locally (declare (optimize (inhibit-warnings 3))) (when *byte-trace* (let ((*byte-trace* nil)) (format *trace-output* "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%" pc fp (current-stack-pointer) byte (subseq eval::*eval-stack* fp (current-stack-pointer)))))) (if (not (logbitp 7 byte)) ;; Some stack operation. No matter what, we need the operand, ;; so compute it. (multiple-value-bind (operand new-pc) (let ((operand (logand byte #xf))) (if (= operand #xf) (let ((operand (component-ref component (1+ pc)))) (if (= operand #xff) (values (component-ref-24 component (+ pc 2)) (+ pc 5)) (values operand (+ pc 2)))) (values operand (1+ pc)))) (if (not (logbitp 6 byte)) (push-eval-stack (if (not (logbitp 5 byte)) (if (not (logbitp 4 byte)) (eval-stack-ref (+ fp operand)) (eval-stack-ref (- fp operand 5))) (if (not (logbitp 4 byte)) (code-header-ref component (+ operand vm:code-constants-offset)) (svref system-constants operand)))) (if (not (logbitp 5 byte)) (push-eval-stack (if (not (logbitp 4 byte)) operand (- (1+ operand)))) (if (not (logbitp 4 byte)) (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack)) (if (zerop operand) (let ((operand (pop-eval-stack))) (declare (type index operand)) (decf (current-stack-pointer) operand)) (decf (current-stack-pointer) operand))))) (byte-interpret component new-pc fp)) (if (not (logbitp 6 byte)) ;; Some kind of call. (let ((args (let ((args (logand byte #x07))) (if (= args #x07) (pop-eval-stack) args)))) (if (not (logbitp 5 byte)) (let ((named (not (not (logbitp 3 byte))))) (if (not (logbitp 4 byte)) ;; Call for single value. (do-call component pc (1+ pc) fp args named) ;; Tail call. (do-tail-call component pc fp args named))) (if (not (logbitp 4 byte)) ;; Call for multiple-values. (do-call component pc (- (1+ pc)) fp args (not (not (logbitp 3 byte)))) (if (not (logbitp 3 byte)) ;; Local call (do-local-call component pc (+ pc 4) fp args) ;; Local tail-call (do-tail-local-call component pc fp args))))) (if (not (logbitp 5 byte)) ;; local-multiple-call, Return, branch, or Xop. (if (not (logbitp 4 byte)) ;; local-multiple-call or return. (if (not (logbitp 3 byte)) ;; Local-multiple-call. (do-local-call component pc (- (+ pc 4)) fp (let ((args (logand byte #x07))) (if (= args #x07) (pop-eval-stack) args))) ;; Return. (let ((num-results (let ((num-results (logand byte #x7))) (if (= num-results 7) (pop-eval-stack) num-results)))) (do-return fp num-results))) ;; Branch or Xop. (if (not (logbitp 3 byte)) ;; Branch. (if (if (not (logbitp 2 byte)) (if (not (logbitp 1 byte)) t (pop-eval-stack)) (if (not (logbitp 1 byte)) (not (pop-eval-stack)) (multiple-value-pop-eval-stack (val1 val2) (eq val1 val2)))) ;; Branch taken. (byte-interpret component (if (not (logbitp 0 byte)) (component-ref-24 component (1+ pc)) (+ pc 2 (component-ref-signed component (1+ pc)))) fp) ;; Branch not taken. (byte-interpret component (if (not (logbitp 0 byte)) (+ pc 4) (+ pc 2)) fp)) ;; Xop. (multiple-value-bind (sub-code new-pc) (let ((operand (logand byte #x7))) (if (= operand #x7) (values (component-ref component (+ pc 1)) (+ pc 2)) (values operand (1+ pc)))) (funcall (the function (svref *byte-xops* sub-code)) component pc new-pc fp)))) ;; Random inline function. (progn (expand-into-inlines) (byte-interpret component (1+ pc) fp)))))) (defun do-local-call (component pc old-pc old-fp num-args) (declare (type pc pc) (type return-pc old-pc) (type stack-pointer old-fp) (type (integer 0 #.call-arguments-limit) num-args)) (invoke-local-entry-point component (component-ref-24 component (1+ pc)) component old-pc (- (current-stack-pointer) num-args) old-fp)) (defun do-tail-local-call (component pc fp num-args) (declare (type code-component component) (type pc pc) (type stack-pointer fp) (type index num-args)) (let ((old-fp (eval-stack-ref (- fp 1))) (old-sp (eval-stack-ref (- fp 2))) (old-pc (eval-stack-ref (- fp 3))) (old-component (eval-stack-ref (- fp 4))) (start-of-args (- (current-stack-pointer) num-args))) (stack-copy old-sp start-of-args num-args) (setf (current-stack-pointer) (+ old-sp num-args)) (invoke-local-entry-point component (component-ref-24 component (1+ pc)) old-component old-pc old-sp old-fp))) (defun invoke-local-entry-point (component target old-component old-pc old-sp old-fp &optional closure-vars) (declare (type pc target) (type return-pc old-pc) (type stack-pointer old-sp old-fp) (type (or null simple-vector) closure-vars)) (when closure-vars (iterate more ((index (1- (length closure-vars)))) (unless (minusp index) (push-eval-stack (svref closure-vars index)) (more (1- index))))) (push-eval-stack old-component) (push-eval-stack old-pc) (push-eval-stack old-sp) (push-eval-stack old-fp) (multiple-value-bind (stack-frame-size entry-pc) (let ((byte (component-ref component target))) (if (= byte 255) (values (component-ref-24 component (1+ target)) (+ target 4)) (values (* byte 2) (1+ target)))) (declare (type pc entry-pc)) (let ((fp (current-stack-pointer))) (allocate-eval-stack stack-frame-size) (byte-interpret component entry-pc fp)))) ;;; BYTE-APPLY -- Internal ;;; ;;; Call a function with some arguments popped off of the interpreter stack, ;;; and restore the SP to the specifier value. ;;; (defun byte-apply (function num-args restore-sp) (declare (function function) (type index num-args)) (let ((start (- (current-stack-pointer) num-args))) (declare (type stack-pointer start)) (macrolet ((frob () `(case num-args ,@(loop for n below 8 collect `(,n (call-1 ,n))) (t (let ((args ()) (end (+ start num-args))) (declare (type stack-pointer end)) (do ((i (1- end) (1- i))) ((< i start)) (declare (fixnum i)) (push (eval-stack-ref i) args)) (setf (current-stack-pointer) restore-sp) (apply function args))))) (call-1 (n) (collect ((binds) (args)) (dotimes (i n) (let ((dum (gensym))) (binds `(,dum (eval-stack-ref (+ start ,i)))) (args dum))) `(let ,(binds) (setf (current-stack-pointer) restore-sp) (funcall function ,@(args)))))) (frob)))) (defun do-call (old-component call-pc ret-pc old-fp num-args named) (declare (type code-component old-component) (type pc call-pc) (type return-pc ret-pc) (type stack-pointer old-fp) (type (integer 0 #.call-arguments-limit) num-args) (type (member t nil) named)) (let* ((old-sp (- (current-stack-pointer) num-args 1)) (fun-or-fdefn (eval-stack-ref old-sp)) (function (if named (or (fdefn-function fun-or-fdefn) (with-debugger-info (old-component call-pc old-fp) (error 'undefined-function :name (fdefn-name fun-or-fdefn)))) fun-or-fdefn))) (declare (type stack-pointer old-sp) (type (or function fdefn) fun-or-fdefn) (type function function)) (typecase function (byte-function (invoke-xep old-component ret-pc old-sp old-fp num-args function)) (byte-closure (invoke-xep old-component ret-pc old-sp old-fp num-args (byte-closure-function function) (byte-closure-data function))) (t (cond ((minusp ret-pc) (let* ((ret-pc (- ret-pc)) (results (multiple-value-list (with-debugger-info (old-component ret-pc old-fp) (byte-apply function num-args old-sp))))) (dolist (result results) (push-eval-stack result)) (push-eval-stack (length results)) (byte-interpret old-component ret-pc old-fp))) (t (push-eval-stack (with-debugger-info (old-component ret-pc old-fp) (byte-apply function num-args old-sp))) (byte-interpret old-component ret-pc old-fp))))))) (defun do-tail-call (component pc fp num-args named) (declare (type code-component component) (type pc pc) (type stack-pointer fp) (type (integer 0 #.call-arguments-limit) num-args) (type (member t nil) named)) (let* ((start-of-args (- (current-stack-pointer) num-args)) (fun-or-fdefn (eval-stack-ref (1- start-of-args))) (function (if named (or (fdefn-function fun-or-fdefn) (with-debugger-info (component pc fp) (error 'undefined-function :name (fdefn-name fun-or-fdefn)))) fun-or-fdefn)) (old-fp (eval-stack-ref (- fp 1))) (old-sp (eval-stack-ref (- fp 2))) (old-pc (eval-stack-ref (- fp 3))) (old-component (eval-stack-ref (- fp 4)))) (declare (type stack-pointer old-fp old-sp start-of-args) (type return-pc old-pc) (type (or fdefn function) fun-or-fdefn) (type function function)) (typecase function (byte-function (stack-copy old-sp start-of-args num-args) (setf (current-stack-pointer) (+ old-sp num-args)) (invoke-xep old-component old-pc old-sp old-fp num-args function)) (byte-closure (stack-copy old-sp start-of-args num-args) (setf (current-stack-pointer) (+ old-sp num-args)) (invoke-xep old-component old-pc old-sp old-fp num-args (byte-closure-function function) (byte-closure-data function))) (t ;; We are tail-calling native code. (cond ((null old-component) ;; We were called by native code. (byte-apply function num-args old-sp)) ((minusp old-pc) ;; We were called for multiple values. So return multiple ;; values. (let* ((old-pc (- old-pc)) (results (multiple-value-list (with-debugger-info (old-component old-pc old-fp) (byte-apply function num-args old-sp))))) (dolist (result results) (push-eval-stack result)) (push-eval-stack (length results)) (byte-interpret old-component old-pc old-fp))) (t ;; We were called for one value. So return one value. (push-eval-stack (with-debugger-info (old-component old-pc old-fp) (byte-apply function num-args old-sp))) (byte-interpret old-component old-pc old-fp))))))) (defvar *byte-trace-calls* nil) (defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep &optional closure-vars) (declare (type (or null code-component) old-component) (type index num-args) (type return-pc ret-pc) (type stack-pointer old-sp old-fp) (type byte-function xep) (type (or null simple-vector) closure-vars)) (when *byte-trace-calls* (let ((*byte-trace-calls* nil) (*byte-trace* nil) (*print-level* debug:*debug-print-level*) (*print-length* debug:*debug-print-length*) (sp (current-stack-pointer))) (format *trace-output* "~&Invoke-XEP: ocode= ~S[~D]~% ~ osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~ Fun= ~S ~@[~S~]~% Args= ~S~%" old-component ret-pc old-sp old-fp num-args sp xep closure-vars (subseq *eval-stack* (- sp num-args) sp)) (force-output *trace-output*))) (let ((entry-point (cond ((typep xep 'simple-byte-function) (unless (eql (simple-byte-function-num-args xep) num-args) (with-debugger-info (old-component ret-pc old-fp) (simple-program-error (intl:gettext "Wrong number of arguments.")))) (simple-byte-function-entry-point xep)) (t (let ((min (hairy-byte-function-min-args xep)) (max (hairy-byte-function-max-args xep))) (cond ((< num-args min) (with-debugger-info (old-component ret-pc old-fp) (simple-program-error (intl:gettext "Not enough arguments.")))) ((<= num-args max) (nth (- num-args min) (hairy-byte-function-entry-points xep))) ((null (hairy-byte-function-more-args-entry-point xep)) (with-debugger-info (old-component ret-pc old-fp) (simple-program-error (intl:gettext "Too many arguments.")))) (t (let* ((more-args-supplied (- num-args max)) (sp (current-stack-pointer)) (more-args-start (- sp more-args-supplied)) (restp (hairy-byte-function-rest-arg-p xep)) (rest (and restp (do ((index (1- sp) (1- index)) (result nil (cons (eval-stack-ref index) result))) ((< index more-args-start) result) (declare (fixnum index)))))) (declare (type index more-args-supplied) (type stack-pointer more-args-start)) (cond ((not (hairy-byte-function-keywords-p xep)) (assert restp) (setf (current-stack-pointer) (1+ more-args-start)) (setf (eval-stack-ref more-args-start) rest) (when (eq :more restp) (incf (current-stack-pointer)) (setf (eval-stack-ref (1+ more-args-start)) (length rest)))) (t (unless (evenp more-args-supplied) (with-debugger-info (old-component ret-pc old-fp) (simple-program-error (intl:gettext "Odd number of keyword arguments.")))) ;; ;; If there are keyword args we need to leave the ;; defaulted and supplied-p values where the more args ;; currently are. There might be more or fewer. And also, ;; we need to flatten the parsed args with the defaults ;; before we scan the keywords. So we copy all the more ;; args to a temporary area at the end of the stack. (let* ((num-more-args (hairy-byte-function-num-more-args xep)) (new-sp (+ more-args-start num-more-args)) (temp (max sp new-sp)) (temp-sp (+ temp more-args-supplied)) (keywords (hairy-byte-function-keywords xep))) (declare (type index temp) (type stack-pointer new-sp temp-sp)) (allocate-eval-stack (- temp-sp sp)) (stack-copy temp more-args-start more-args-supplied) (when restp (setf (eval-stack-ref more-args-start) rest) (incf more-args-start) (when (eq :more restp) (setf (eval-stack-ref (1+ more-args-start)) (length rest)) (incf more-args-start))) (let ((index more-args-start)) (dolist (keyword keywords) (setf (eval-stack-ref index) (cadr keyword)) (incf index) (when (caddr keyword) (setf (eval-stack-ref index) nil) (incf index)))) (let ((index temp-sp) (allow (eq (hairy-byte-function-keywords-p xep) :allow-others)) (bogus-key nil) (bogus-key-p nil)) (declare (type fixnum index)) (loop (decf index 2) (when (< index temp) (return)) (let ((key (eval-stack-ref index)) (value (eval-stack-ref (1+ index)))) (if (eq key :allow-other-keys) (setf allow value) (let ((target more-args-start)) (declare (type stack-pointer target)) (dolist (keyword keywords (setf bogus-key key bogus-key-p t)) (cond ((eq (car keyword) key) (setf (eval-stack-ref target) value) (when (caddr keyword) (setf (eval-stack-ref (1+ target)) t)) (return)) ((caddr keyword) (incf target 2)) (t (incf target)))))))) (when (and bogus-key-p (not allow)) (with-debugger-info (old-component ret-pc old-fp) (simple-program-error (intl:gettext "Unknown keyword: ~S") bogus-key)))) (setf (current-stack-pointer) new-sp))))) (hairy-byte-function-more-args-entry-point xep)))))))) (declare (type pc entry-point)) (invoke-local-entry-point (byte-function-component xep) entry-point old-component ret-pc old-sp old-fp closure-vars))) (defun do-return (fp num-results) (declare (type stack-pointer fp) (type index num-results)) (let ((old-component (eval-stack-ref (- fp 4)))) (typecase old-component (code-component ;; Returning to more byte-interpreted code. (do-local-return old-component fp num-results)) (null ;; Returning to native code. (let ((old-sp (eval-stack-ref (- fp 2)))) (case num-results (0 (setf (current-stack-pointer) old-sp) (values)) (1 (let ((result (pop-eval-stack))) (setf (current-stack-pointer) old-sp) result)) (t (let ((results nil)) (dotimes (i num-results) (push (pop-eval-stack) results)) (setf (current-stack-pointer) old-sp) (values-list results)))))) (t ;; ### Function end breakpoint? (error (intl:gettext "function-end breakpoints not supported.")))))) (defun do-local-return (old-component fp num-results) (declare (type stack-pointer fp) (type index num-results)) (let ((old-fp (eval-stack-ref (- fp 1))) (old-sp (eval-stack-ref (- fp 2))) (old-pc (eval-stack-ref (- fp 3)))) (declare (type (signed-byte 25) old-pc)) (if (plusp old-pc) ;; Wants single value. (let ((result (if (zerop num-results) nil (eval-stack-ref (- (current-stack-pointer) num-results))))) (setf (current-stack-pointer) old-sp) (push-eval-stack result) (byte-interpret old-component old-pc old-fp)) ;; Wants multiple values. (progn (stack-copy old-sp (- (current-stack-pointer) num-results) num-results) (setf (current-stack-pointer) (+ old-sp num-results)) (push-eval-stack num-results) (byte-interpret old-component (- old-pc) old-fp))))) (declaim (end-block byte-interpret byte-interpret-byte invoke-xep)) cmucl-21a/src/code/c-call.lisp000066400000000000000000000075021260377556400163120ustar00rootroot00000000000000;;; -*- Package: C-CALL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/c-call.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains some extensions to the Alien facility to simplify ;;; importing C interfaces. ;;; (in-package "C-CALL") (use-package "ALIEN") (use-package "ALIEN-INTERNALS") (use-package "SYSTEM") (intl:textdomain "cmucl") (export '(char short int long long-long unsigned-char unsigned-short unsigned-int unsigned-long unsigned-long-long float double c-string void)) ;;;; Extra types. (def-alien-type char (integer 8)) (def-alien-type short (integer 16)) (def-alien-type int (integer 32)) (def-alien-type long (integer #-alpha 32 #+alpha 64)) (def-alien-type long-long (integer 64)) (def-alien-type unsigned-char (unsigned 8)) (def-alien-type unsigned-short (unsigned 16)) (def-alien-type unsigned-int (unsigned 32)) (def-alien-type unsigned-long (unsigned #-alpha 32 #+alpha 64)) (def-alien-type unsigned-long-long (unsigned 64)) (def-alien-type float single-float) (def-alien-type double double-float) (def-alien-type-translator void () (parse-alien-type '(values))) ;;;; C string support. (def-alien-type-class (c-string :include pointer :include-args (to))) (def-alien-type-translator c-string () (make-alien-c-string-type :to (parse-alien-type 'char))) (def-alien-type-method (c-string :unparse) (type) (declare (ignore type)) 'c-string) (def-alien-type-method (c-string :lisp-rep) (type) (declare (ignore type)) '(or simple-base-string null (alien (* char)))) (def-alien-type-method (c-string :naturalize-gen) (type alien) (declare (ignore type)) `(if (zerop (sap-int ,alien)) nil (%naturalize-c-string ,alien))) #-unicode (def-alien-type-method (c-string :deport-gen) (type value) (declare (ignore type)) `(etypecase ,value (null (int-sap 0)) ((alien (* char)) (alien-sap ,value)) (simple-base-string (vector-sap ,value)))) #+unicode (def-alien-type-method (c-string :deport-gen) (type value) (declare (ignore type)) (let ((s (gensym "C-STRING-")) (len (gensym "LEN-")) (k (gensym "IDX-"))) `(etypecase ,value (null (int-sap 0)) ((alien (* char)) (alien-sap ,value)) (simple-base-string ;; FIXME: What should we do here? For now, we just create an ;; 8-bit array and copy our characters (the low 8-bits of each ;; character!) to the 8-bit array. (let* ((,len (length ,value)) (,s (make-array (1+ ,len) :element-type '(unsigned-byte 8)))) (dotimes (,k ,len) (setf (aref ,s ,k) (logand #xff (char-code (aref ,value ,k))))) (setf (aref ,s ,len) 0) (vector-sap ,s)))))) #-unicode (defun %naturalize-c-string (sap) (declare (type system-area-pointer sap)) (locally (declare (optimize (speed 3) (safety 0))) (let ((length (loop for offset of-type fixnum upfrom 0 until (zerop (sap-ref-8 sap offset)) finally (return offset)))) (let ((result (make-string length))) (kernel:copy-from-system-area sap 0 result (* vm:vector-data-offset vm:word-bits) (* length vm:byte-bits)) result)))) ;; FIXME: What should we do? For now, just take the 8-bit strings ;; returned from C and create a new Lisp string containing those ;; characters. #+unicode (defun %naturalize-c-string (sap) (declare (type system-area-pointer sap)) (let ((length (loop for offset of-type fixnum upfrom 0 until (zerop (sap-ref-8 sap offset)) finally (return offset)))) (let ((result (make-string length))) (dotimes (k length) (setf (aref result k) (code-char (sap-ref-8 sap k)))) result))) cmucl-21a/src/code/char.lisp000066400000000000000000000376121260377556400161010ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/char.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Character functions for Spice Lisp. Part of the standard Spice Lisp ;;; environment. ;;; ;;; This file assumes the use of ASCII codes and the specific character formats ;;; used in Spice Lisp and Vax Common Lisp. It is optimized for performance ;;; rather than for portability and elegance, and may have to be rewritten if ;;; the character representation is changed. ;;; ;;; Written by Guy Steele. ;;; Rewritten by David Dill. ;;; Hacked up for speed by Scott Fahlman. ;;; Font support flushed and type hackery rewritten by Rob MacLachlan. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(char-code-limit standard-char-p graphic-char-p alpha-char-p upper-case-p lower-case-p both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-greaterp char-not-lessp character char-code code-char char-upcase char-titlecase title-case-p char-downcase digit-char char-int char-name name-char codepoint-limit codepoint)) ;;; Compile some trivial character operations via inline expansion: ;;; (declaim (inline standard-char-p graphic-char-p alpha-char-p upper-case-p lower-case-p both-case-p alphanumericp char-int)) (declaim (maybe-inline digit-char-p digit-weight)) (defconstant char-code-limit #-unicode 256 #+unicode 65536 "The upper exclusive bound on values produced by CHAR-CODE.") (deftype char-code () `(integer 0 (,char-code-limit))) (defconstant codepoint-limit #x110000 "The upper exclusive bound on the value of a Unicode codepoint") ;;; The range of a Unicode code point (deftype codepoint () `(integer 0 (,codepoint-limit))) (macrolet ((frob (char-names-list) (collect ((results)) (dolist (code char-names-list) (destructuring-bind (ccode names) code (dolist (name names) (results (cons name (code-char ccode)))))) `(defparameter char-name-alist ',(results) "This is the alist of (character-name . character) for characters with long names. The first name in this list for a given character is used on typeout and is the preferred form for input.")))) ;; Note: the char-name listed here should be what string-capitalize ;; would produce. This is needed to match what format ~:C would ;; produce. (frob ((#x00 ("Null" "^@" "NUL")) (#x01 ("^A" "SOH")) (#x02 ("^B" "STX")) (#x03 ("^C" "ETX")) (#x04 ("^D" "EOT")) (#x05 ("^E" "ENQ")) (#x06 ("^F" "ACK")) (#x07 ("Bell" "^g" "BEL")) (#x08 ("Backspace" "^h" "BS")) (#x09 ("Tab" "^i" "HT")) (#x0A ("Newline" "Linefeed" "^j" "LF" "NL" )) (#x0B ("Vt" "^k")) (#x0C ("Page" "^l" "Form" "Formfeed" "FF" "NP")) (#x0D ("Return" "^m" "RET" "CR")) (#x0E ("^N" "SO")) (#x0F ("^O" "SI")) (#x10 ("^P" "DLE")) (#x11 ("^Q" "DC1")) (#x12 ("^R" "DC2")) (#x13 ("^S" "DC3")) (#x14 ("^T" "DC4")) (#x15 ("^U" "NAK")) (#x16 ("^V" "SYN")) (#x17 ("^W" "ETB")) (#x18 ("^X" "CAN")) (#x19 ("^Y" "EM" "EOM")) (#x1A ("^Z" "SUB")) (#x1B ("Escape" "^[" "Altmode" "ESC" "Alt")) (#x1C ("Is4" "FS" "^\\")) (#x1D ("Is3" "GS" "^]")) (#x1E ("Is2" "RS" "^^")) (#x1F ("Is1" "US" "^_")) (#x20 ("Space" "SP" "SPC")) (#x7f ("Rubout" "Delete" "DEL"))))) ;;;; Accessor functions: (defun char-code (char) "Returns the integer code of CHAR." (etypecase char (base-char (char-code (truly-the base-char char))))) (defun char-int (char) "Returns the integer code of CHAR. This is the same as char-code, as CMU Common Lisp does not implement character bits or fonts." (char-code char)) (defun code-char (code) "Returns the character with the code CODE." (declare (type char-code code)) (code-char code)) (defun character (object) "Coerces its argument into a character object if possible. Accepts characters, strings and symbols of length 1." (flet ((do-error (control args) (error 'simple-type-error :datum object ;;?? how to express "symbol with name of length 1"? :expected-type '(or character (string 1)) :format-control control :format-arguments args))) (typecase object (character object) (string (if (= 1 (length (the string object))) (char object 0) (do-error (intl:gettext "String is not of length one: ~S") (list object)))) (symbol (if (= 1 (length (symbol-name object))) (schar (symbol-name object) 0) (do-error (intl:gettext "Symbol name is not of length one: ~S") (list object)))) (t (do-error (intl:gettext "~S cannot be coerced to a character.") (list object)))))) (defun char-name (char) "Given a character object, char-name returns the name for that object (a symbol)." (let ((name (car (rassoc char char-name-alist)))) (if name name #-unicode nil #+unicode ;; Return the Unicode name of the character, ;; or U+xxxx if it doesn't have a name (let* ((code (char-code char)) (name (unicode-name code))) (if name (nstring-capitalize (nsubstitute #\_ #\Space name)) (format nil "U+~4,'0X" code)))))) (defun name-char (name) "Given an argument acceptable to string, name-char returns a character object whose name is that symbol, if one exists, otherwise NIL." (if (and (stringp name) (> (length name) 2) (string-equal name "U+" :end1 2)) (code-char (parse-integer name :radix 16 :start 1)) (or (cdr (assoc (string name) char-name-alist :test #'string-equal)) #-unicode nil #+unicode (let ((code (unicode-name-to-codepoint (nsubstitute #\Space #\_ (string-upcase name))))) (if code (code-char code) nil))))) ;;;; Predicates: (defun standard-char-p (char) "The argument must be a character object. Standard-char-p returns T if the argument is a standard character -- one of the 95 ASCII printing characters or ." (declare (character char)) (and (typep char 'base-char) (let ((n (char-code (the base-char char)))) (or (< 31 n 127) (= n 10))))) (defun %standard-char-p (thing) "Return T if and only if THING is a standard-char. Differs from standard-char-p in that THING doesn't have to be a character." (and (characterp thing) (standard-char-p thing))) (defun graphic-char-p (char) "The argument must be a character object. Graphic-char-p returns T if the argument is a printing character, otherwise returns NIL." (declare (character char)) (and (typep char 'base-char) (let ((m (char-code (the base-char char)))) (or (< 31 m 127) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (>= (unicode-category m) +unicode-category-graphic+)))))) (defun alpha-char-p (char) "The argument must be a character object. Alpha-char-p returns T if the argument is an alphabetic character; otherwise NIL." (declare (character char)) (let ((m (char-code char))) (or (< 64 m 91) (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (<= +unicode-category-letter+ (unicode-category m) (+ +unicode-category-letter+ #x0F)))))) (defun upper-case-p (char) "The argument must be a character object; upper-case-p returns T if the argument is an upper-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) (or (< 64 m 91) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (= (unicode-category m) +unicode-category-upper+))))) (defun lower-case-p (char) "The argument must be a character object; lower-case-p returns T if the argument is a lower-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) (or (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (= (unicode-category m) +unicode-category-lower+))))) (defun title-case-p (char) "The argument must be a character object; title-case-p returns T if the argument is a title-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) (or (< 64 m 91) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (= (unicode-category m) +unicode-category-title+))))) (defun both-case-p (char) "The argument must be a character object. Both-case-p returns T if the argument is an alphabetic character and if the character exists in both upper and lower case. For ASCII, this is the same as Alpha-char-p." (declare (character char)) (let ((m (char-code char))) (or (< 64 m 91) (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (<= +unicode-category-upper+ (unicode-category m) +unicode-category-title+))))) (defun digit-char-p (char &optional (radix 10.)) "If char is a digit in the specified radix, returns the fixnum for which that digit stands, else returns NIL. Radix defaults to 10 (decimal)." (declare (character char) (type (integer 2 36) radix)) (let ((m (- (char-code char) 48))) (declare (fixnum m)) (cond ((<= radix 10.) ;; Special-case decimal and smaller radices. (if (and (>= m 0) (< m radix)) m nil)) ;; Digits 0 - 9 are used as is, since radix is larger. ((and (>= m 0) (< m 10)) m) ;; Check for upper case A - Z. ((and (>= (setq m (- m 7)) 10) (< m radix)) m) ;; Also check lower case a - z. ((and (>= (setq m (- m 32)) 10) (< m radix)) m) ;; Else, fail. (t nil)))) (defun alphanumericp (char) "Given a character-object argument, alphanumericp returns T if the argument is either numeric or alphabetic." (declare (character char)) (let ((m (char-code char))) ;; Shortcut for ASCII digits and upper and lower case ASCII letters (or (< 47 m 58) (< 64 m 91) (< 96 m 123) #+(and unicode (not unicode-bootstrap)) (and (> m 127) (<= +unicode-category-letter+ (unicode-category m) (+ +unicode-category-letter+ #x0F)))))) (defun char= (character &rest more-characters) "Returns T if all of its arguments are the same character." (do ((clist more-characters (cdr clist))) ((atom clist) T) (unless (eq (car clist) character) (return nil)))) (defun char/= (character &rest more-characters) "Returns T if no two of its arguments are the same character." (do* ((head character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (do* ((l list (cdr l))) ;inner loop returns T ((atom l) T) ; iff head /= rest. (if (eq head (car l)) (return nil))) (return nil)))) (defun char< (character &rest more-characters) "Returns T if its arguments are in strictly increasing alphabetic order." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (< (char-int c) (char-int (car list))) (return nil)))) (defun char> (character &rest more-characters) "Returns T if its arguments are in strictly decreasing alphabetic order." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (> (char-int c) (char-int (car list))) (return nil)))) (defun char<= (character &rest more-characters) "Returns T if its arguments are in strictly non-decreasing alphabetic order." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (<= (char-int c) (char-int (car list))) (return nil)))) (defun char>= (character &rest more-characters) "Returns T if its arguments are in strictly non-increasing alphabetic order." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (>= (char-int c) (char-int (car list))) (return nil)))) ;;; Equal-Char-Code is used by the following functions as a version of char-int ;;; which loses case info. We convert to lower case (defmacro equal-char-code (character) `(let ((ch (char-code ,character))) ;; Handle ASCII separately for bootstrapping and for unidata missing. (if (< 64 ch 91) (+ ch 32) #-(and unicode (not unicode-bootstrap)) ch #+(and unicode (not unicode-bootstrap)) (if (> ch 127) (unicode-lower ch) ch)))) (defun char-equal (character &rest more-characters) "Returns T if all of its arguments are the same character. Case is ignored." (do ((clist more-characters (cdr clist))) ((atom clist) T) (unless (= (equal-char-code (car clist)) (equal-char-code character)) (return nil)))) (defun char-not-equal (character &rest more-characters) "Returns T if no two of its arguments are the same character. Case is ignored." (do* ((head character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (do* ((l list (cdr l))) ((atom l) T) (if (= (equal-char-code head) (equal-char-code (car l))) (return nil))) (return nil)))) (defun char-lessp (character &rest more-characters) "Returns T if its arguments are in strictly increasing alphabetic order. Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (< (equal-char-code c) (equal-char-code (car list))) (return nil)))) (defun char-greaterp (character &rest more-characters) "Returns T if its arguments are in strictly decreasing alphabetic order. Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (> (equal-char-code c) (equal-char-code (car list))) (return nil)))) (defun char-not-greaterp (character &rest more-characters) "Returns T if its arguments are in strictly non-decreasing alphabetic order. Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (<= (equal-char-code c) (equal-char-code (car list))) (return nil)))) (defun char-not-lessp (character &rest more-characters) "Returns T if its arguments are in strictly non-increasing alphabetic order. Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) (unless (>= (equal-char-code c) (equal-char-code (car list))) (return nil)))) ;;;; Miscellaneous functions: (defun char-upcase (char) "Returns CHAR converted to upper-case if that is possible." (declare (character char)) #-(and unicode (not unicode-bootstrap)) (if (lower-case-p char) (code-char (- (char-code char) 32)) char) #+(and unicode (not unicode-bootstrap)) (let ((m (char-code char))) (cond ((> m 127) (code-char (unicode-upper m))) ((< 96 m 123) (code-char (- m 32))) (t char)))) (defun char-titlecase (char) "Returns CHAR converted to title-case if that is possible." (declare (character char)) #-(and unicode (not unicode-bootstrap)) (if (lower-case-p char) (code-char (- (char-code char) 32)) char) #+(and unicode (not unicode-bootstrap)) (let ((m (char-code char))) (cond ((> m 127) (code-char (unicode-title m))) ((< 96 m 123) (code-char (- m 32))) (t char)))) (defun char-downcase (char) "Returns CHAR converted to lower-case if that is possible." (declare (character char)) #-(and unicode (not unicode-bootstrap)) (if (upper-case-p char) (code-char (+ (char-code char) 32)) char) #+(and unicode (not unicode-bootstrap)) (let ((m (char-code char))) (cond ((> m 127) (code-char (unicode-lower m))) ((< 64 m 91) (code-char (+ m 32))) (t char)))) (defun digit-char (weight &optional (radix 10)) "All arguments must be integers. Returns a character object that represents a digit of the given weight in the specified radix. Returns NIL if no such character exists." (declare (type (integer 2 36) radix) (type unsigned-byte weight)) (and (typep weight 'fixnum) (>= weight 0) (< weight radix) (< weight 36) (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))))) cmucl-21a/src/code/class.lisp000066400000000000000000001435151260377556400162710ustar00rootroot00000000000000;;; -*- Package: Kernel -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/class.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains structures and functions for the maintenance of basic ;;; information about defined types. Different object systems can be supported ;;; simultaneously. Some of the functions here are nominally generic, and are ;;; overwritten when CLOS is loaded. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") (export '(layout layout-hash layout-hash-length layout-hash-max initialize-layout-hash layout-class layout-invalid layout-inherits layout-inheritance-depth layout-length layout-info layout-pure layout-of structure-class-p slot-class-print-function structure-class-make-load-form-fun find-layout class-proper-name class-init register-layout basic-structure-class slot-class funcallable-instance funcallable-structure-class make-funcallable-structure-class funcallable-structure-class-p make-standard-class random-pcl-class make-random-pcl-class built-in-class-direct-superclasses find-class-cell class-cell-name class-cell-class make-layout make-undefined-class insured-find-class redefine-layout-warning std-compute-class-precedence-list %class-name %class-layout %class-state %class-direct-superclasses %class-subclasses %class-pcl-class)) (in-package "LISP") (export '(class-name)) (in-package "KERNEL") (shadow '("CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF")) (with-cold-load-init-forms) ;;; Table mapping class names to layouts for classes we have referenced but not ;;; yet loaded. This is initialized from an ALIST created by Genesis ;;; describing the layouts it created at cold-load time. *LAYOUT-HASH-INITS* ;;; is a list of all the layouts whose hash hasn't been initialized. We delay ;;; this because the random-number generator needs top-level forms to work. ;;; (defvar *forward-referenced-layouts*) (defvar lisp::*initial-layouts*) (defvar *layout-hash-inits*) (cold-load-init (setq *forward-referenced-layouts* (make-hash-table :test #'equal)) (setq *layout-hash-inits* ()) (dolist (x lisp::*initial-layouts*) (setf (gethash (car x) *forward-referenced-layouts*) (cdr x)) (push (cdr x) *layout-hash-inits*)) (makunbound 'lisp::*initial-layouts*)) ;;;; Class definition structures: ;;; The LAYOUT structure is pointed to by the first cell of instance (or ;;; structure) objects. It represents what we need to know for type checking ;;; and garbage collection. Whenever a class is incompatibly redefined, a new ;;; layout is allocated. If two object's layouts are EQ, then they are exactly ;;; the same type. ;;; ;;; LAYOUTs are treated specially by the dumper so that genesis can help us ;;; bootstrap the type system. Only layouts for named classes can be dumped. ;;; This is resolved at load-time to the current layout for the class of that ;;; name --- except that genesis simply ensures that only one layout is ;;; allocated for each class (interns the layouts by name.) Only the INHERITS, ;;; INHERITANCE-DEPTH and LENGTH slots are dumped. In normal load, these slots ;;; had better agree with any current loaded value. In cold load, these slots ;;; are used to create the LAYOUT if it doesn't exist yet (other slots left ;;; unitialized.) ;;; (defstruct (layout (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t) (format stream (intl:gettext "Layout for ~S~@[, Invalid=~S~]") (class-proper-name (layout-class s)) (layout-invalid s))))) (:make-load-form-fun :ignore-it) (:constructor %make-layout)) ;; ;; Some hash bits for this layout. Sleazily accessed via %INSTANCE-REF, see ;; LAYOUT-HASH. (hash0 0 :type index) (hash1 0 :type index) (hash2 0 :type index) (hash3 0 :type index) (hash4 0 :type index) (hash5 0 :type index) (hash6 0 :type index) (hash7 0 :type index) ;; ;; The class this is a layout for. (class (required-argument) :type kernel::class) ;; ;; NIL if this is the latest layout for this class. If non-null, then the ;; class was changed after this instance was created. The exact value may ;; provide some information about what to do. (invalid nil) ;; ;; Vector of the layouts for all classes we inherit. If hierarchical ;; these are in order from most general down to (but not including) this ;; class. (inherits #() :type simple-vector) ;; ;; Number of classes this class hierachically inherits ;; (length inherits), or -1 if not hierarchical. (inheritance-depth -1 :type (or index (integer -1 -1))) ;; ;; The number of top-level descriptor cells in each instance. (length 0 :type index) ;; ;; If this layout has some kind of compiler meta-info, then this is it. If a ;; structure, then we store the DEFSTRUCT-DESCRIPTION here. (info nil) ;; ;; True if objects of this class are never modified to contain dynamic ;; pointers in their slots or constant-like substructure (hence can be copied ;; into read-only space by purify.) ;; ;; ### this slot is known to the C startup code. (pure nil :type (member t nil 0))) ;;; MAKE-LAYOUT -- Interface ;;; ;;; Make a layout and initialize it. If type system is initialized ;;; (actually, the top-level forms for RANDOM run), then initialize the hash ;;; now, otherwise, delay initialization. ;;; (defun make-layout (&rest args &key &allow-other-keys) (let ((res (apply #'%make-layout args))) (if *type-system-initialized* (initialize-layout-hash res) (push res *layout-hash-inits*)) res)) (defconstant layout-hash-length 8) (declaim (inline layout-hash)) (defun layout-hash (layout i) (declare (type layout layout) (type index i)) (truly-the index (%instance-ref layout (1+ i)))) (declaim (inline (setf layout-hash))) (defun (setf layout-hash) (new-value layout i) (declare (type layout layout) (type index new-value i)) (setf (%instance-ref layout (1+ i)) new-value)) (defconstant layout-hash-max (ash most-positive-fixnum -3) "The inclusive upper bound on LAYOUT-HASH values.") (defvar *layout-hash-seed* nil) ;;; INITIALIZE-LAYOUT-HASH -- Interface ;;; ;;; Set the layout-hash slots to non-zero random numbers between 1 and ;;; layout-hash-max (inclusive). The layout is returned. ;;; (defun initialize-layout-hash (layout) (let ((seed *layout-hash-seed*)) (unless seed (setq seed (setq *layout-hash-seed* (make-random-state)))) (dotimes (i layout-hash-length) (setf (layout-hash layout i) (1+ (random layout-hash-max seed))))) layout) ;;; order-layout-inherits -- Interface ;;; ;;; Arrange the inherited layouts to appear at their expected depth, ensuring ;;; that hierarchical type tests succeed. Layouts with a specific depth are ;;; placed first, then the non-hierarchical layouts fill remaining elements. ;;; Any empty elements are filled with layout copies ensuring that all ;;; elements have a valid layout. This re-ordering may destroy CPL ordering so ;;; the inherits should not be read as being in CPL order, and further ;;; duplicates may be introduced. ;;; (defun order-layout-inherits (layouts) (declare (simple-vector layouts)) (let ((length (length layouts)) (max-depth -1)) (dotimes (i length) (let ((depth (layout-inheritance-depth (svref layouts i)))) (when (> depth max-depth) (setf max-depth depth)))) (let* ((new-length (max (1+ max-depth) length)) (inherits (make-array new-length))) (dotimes (i length) (let* ((layout (svref layouts i)) (depth (layout-inheritance-depth layout))) (unless (eql depth -1) (let ((old-layout (svref inherits depth))) (unless (or (eql old-layout 0) (eq old-layout layout)) (error (intl:gettext "Layout depth conflict: ~S~% ~ (~S collides at ~S with ~S)~%") layouts layout depth old-layout))) (setf (svref inherits depth) layout)))) (do ((i 0 (1+ i)) (j 0)) ((>= i length)) (declare (type index i j)) (let* ((layout (svref layouts i)) (depth (layout-inheritance-depth layout))) (when (eql depth -1) (loop (when (eql (svref inherits j) 0) (return)) (incf j)) (setf (svref inherits j) layout)))) (do ((i (1- new-length) (1- i))) ((< i 0)) (declare (type fixnum i)) (when (eql (svref inherits i) 0) (setf (svref inherits i) (svref inherits (1+ i))))) inherits))) ;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a ;;; CTYPE structure as recognized by the type system. ;;; (defstruct (class (:conc-name %class-) (:make-load-form-fun class-make-load-form-fun) (:print-function %print-class) (:include ctype (:class-info (type-class-or-lose 'class))) (:pure nil)) ;; ;; Optional name, for printing. (name nil) ;; ;; Current layout for this class. Null if not assigned yet. (layout nil :type (or layout null)) ;; ;; How sure we are that this class won't be redefined. If :READ-ONLY, we are ;; committed to not changing the effective slots or superclasses. If ;; :SEALED, we can't even add subclasses. (state nil :type (member nil :read-only :sealed)) ;; ;; Direct superclasses of this class. (direct-superclasses () :type list) ;; ;; Representation of all of the subclasses (direct or indirect) of this ;; class. NIL if no subclasses or not initalized yet. Otherwise, an EQ ;; hash-table mapping class-objects to the subclass layout that was in effect ;; at the time the subclass was created. (subclasses nil :type (or hash-table null)) ;; ;; The PCL class object, or NIL if none assigned yet. (pcl-class nil)) ;;; ;;; Remove this whole stuff once everyone has bootstrapped the ;;; LISP:CLASS = PCL:CLASS stuff, that is, when the bootstrap file ;;; using this feature is no longer needed. ;;; #+bootstrap-lisp-class=pcl-class (macrolet ((def (o n) `(progn (defun ,o (x) (,n x)) (defun (setf ,o) (v x) (setf (,n x) v))))) (def class-layout %class-layout) (def class-name %class-name) (def class-state %class-state) (def class-direct-subclasses %class-direct-superclasses) (def class-subclasses %class-subclasses)) ;;; (defun class-make-load-form-fun (class) (let ((name (%class-name class))) (unless (and name (eq (find-class name nil) class)) (error (intl:gettext "Can't use anonymous or undefined class as constant:~% ~S") class)) `(find-class ',name))) ;;; (defun %print-class (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t :type t) (format stream (intl:gettext "~:[~;~:*~S~]~@[ (~(~A~))~]") (%class-name s) (%class-state s)))) ;;; The UNDEFINED-CLASS is a cookie we make up to stick in forward referenced ;;; layouts. Users should never see them. ;;; (defstruct (undefined-class (:include class) (:constructor make-undefined-class (name)))) ;;; BUILT-IN-CLASS is used to represent the standard classes that aren't ;;; defined with DEFSTRUCT and other specially implemented primitve types whose ;;; only attribute is their name. ;;; ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they are ;;; effectively DEFTYPE'd to some other type (usually a union of other classes ;;; or a "primitive" type such as NUMBER, ARRAY, etc.) This translation is ;;; done when type specifiers are parsed. Type system operations (union, ;;; subtypep, etc.) should never encounter translated classes, only their ;;; translation. ;;; (defstruct (built-in-class (:include class)) ;; ;; Type we translate to on parsing. If NIL, then this class stands on its ;; own. Only :INITIALIZING for a period during cold-load. See below. (translation nil :type (or ctype (member nil :initializing)))) ;;; Class with print function, but not necessarily a structure class. ;;; (CONDITIONs) ;;; (defstruct (slot-class (:include class)) ;; ;; Print function, or NIL if none. (print-function nil :type (or function symbol null))) ;;; STRUCTURE-CLASS represents what we need to know about structure classes. ;;; Non-structure "typed" defstructs are a special case, and don't have a ;;; corresponding class. ;;; (defstruct (basic-structure-class (:include slot-class))) (defstruct (structure-class (:include basic-structure-class)) ;; ;; MAKE-LOAD-FORM method, or NIL if none. :J-D-I-N dumps the slots. ;; :IGNORE-IT is used for magic structures which the compiler inserts in IR1, ;; but that are never actually dumped. (make-load-form-fun nil :type (or function symbol (member :just-dump-it-normally :ignore-it nil))) ;; ;; If true, a default keyword constructor for this structure. (constructor nil :type (or function null))) ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable structures, ;;; which are used to implement generic functions. ;;; (defstruct (funcallable-structure-class (:include basic-structure-class))) ;;;; Class namespace: ;;; FIND-CLASS-CELL, CLASS-CELL-NAME, CLASS-CELL-CLASS -- Interface ;;; ;;; We use an indirection to allow forward referencing of class definitions ;;; with load-time resolution. ;;; (defstruct (class-cell (:constructor make-class-cell (name &optional class)) (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :type t) (prin1 (class-cell-name s) stream)))) (:make-load-form-fun (lambda (cell) `(find-class-cell ',(class-cell-name cell))))) ;; ;; Name of class we expect to find. (name nil :type symbol :read-only t) ;; ;; Class or NIL if not yet defined. (class nil :type (or class null))) (defun find-class-cell (name) (or (info type class name) (setf (info type class name) (make-class-cell name)))) ;;; FIND-CLASS -- Public ;;; (defun find-class (name &optional (errorp t) environment) "Return the class with the specified Name. If ERRORP is false, then NIL is returned when no such class exists." (declare (type symbol name) (ignore environment)) (let ((res (class-cell-class (find-class-cell name)))) (if (or res (not errorp)) res (error 'simple-type-error :datum name :expected-type t ; Not really :format-control (intl:gettext "Class not yet defined:~% ~S") :format-arguments (list name))))) ;;; (defun (setf find-class) (new-value name &optional (errorp t) environment) (declare (type (or null class) new-value) (ignore errorp environment)) (cond ((null new-value) ;; Clear info db if name names a class (ecase (info type kind name) (:primitive (error (intl:gettext "Illegal to redefine standard type ~S.") name)) (:defined) ((nil)) (:instance (setf (info type kind name) nil (info type class name) nil (info type documentation name) nil (info type compiler-layout name) nil)))) (t (ecase (info type kind name) ((nil)) (:instance (let ((old (class-of (find-class name))) (new (class-of new-value))) (unless (eq old new) (warn (intl:gettext "Changing meta-class of ~S from ~S to ~S.") name (%class-name old) (%class-name new))))) (:primitive (error (intl:gettext "Illegal to redefine standard type ~S.") name)) (:defined (warn (intl:gettext "Redefining DEFTYPE type to be a class: ~S.") name) (setf (info type expander name) nil))) (remhash name *forward-referenced-layouts*) (%note-type-defined name) (setf (info type kind name) :instance) (setf (class-cell-class (find-class-cell name)) new-value) (unless (eq (info type compiler-layout name) (%class-layout new-value)) (setf (info type compiler-layout name) (%class-layout new-value))))) new-value) ;;; INSURED-FIND-CLASS -- Interface ;;; ;;; Called when we are about to define Name as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is always of ;;; the desired class. The second result is any existing layout for this name. ;;; (defun insured-find-class (name predicate constructor) (declare (function predicate constructor)) (let* ((old (find-class name nil)) (res (if (and old (funcall predicate old)) old (funcall constructor :name name))) (found (or (gethash name *forward-referenced-layouts*) (when old (%class-layout old))))) (when found (setf (layout-class found) res)) (values res found))) ;;; CLASS-PROPER-NAME -- Exported ;;; ;;; If the class has a proper name, return the name, otherwise return ;;; the class. ;;; (defun class-proper-name (class) (declare (type class class)) (let ((name (%class-name class))) (if (and name (eq (find-class name nil) class)) name class))) ;;;; CLASS type operations: (define-type-class class) ;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two ;;; classes are equal, since there are EQ checks in those operations. ;;; (define-type-method (class :simple-=) (type1 type2) (assert (not (eq type1 type2))) (values nil t)) (define-type-method (class :simple-subtypep) (class1 class2) (assert (not (eq class1 class2))) (let ((subclasses (%class-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) (values t t) (values nil t)))) ;;; SEALED-CLASS-INTERSECTION -- Internal ;;; ;;; When finding the intersection of a sealed class and some other class ;;; (not hierarchically related) the intersection is the union of the currently ;;; shared subclasses. ;;; (defun sealed-class-intersection (sealed other) (declare (type class sealed other)) (let ((s-sub (%class-subclasses sealed)) (o-sub (%class-subclasses other))) (if (and s-sub o-sub) (collect ((res *empty-type* type-union)) (do-hash (subclass layout s-sub) (declare (ignore layout)) (when (gethash subclass o-sub) (res (specifier-type subclass)))) (res)) *empty-type*))) ;;; If one is a subclass of the other, then that is the intersection, but we ;;; can only be sure the intersection is otherwise empty if they are structure ;;; classes, since a subclass of both might be defined. If either class is ;;; sealed, we can eliminate this possibility. ;;; (define-type-method (class :simple-intersection) (class1 class2) (declare (type class class1 class2)) (cond ((eq class1 class2) class1) ((let ((subclasses (%class-subclasses class2))) (and subclasses (gethash class1 subclasses))) class1) ((let ((subclasses (%class-subclasses class1))) (and subclasses (gethash class2 subclasses))) class2) ((or (basic-structure-class-p class1) (basic-structure-class-p class2)) *empty-type*) ((eq (%class-state class1) :sealed) (sealed-class-intersection class1 class2)) ((eq (%class-state class2) :sealed) (sealed-class-intersection class2 class1)) (t nil))) ;;; ;;; KLUDGE: we need this because of the need to represent ;;; intersections of two classes, even when empty at a given time, as ;;; uncanonicalized intersections because of the possibility of later ;;; defining a subclass of both classes. The necessity for changing ;;; the default return value from SUBTYPEP to NIL, T if no alternate ;;; method is present comes about because, unlike the other places we ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the ;;; like, classes are in their own hierarchy with no possibility of ;;; mixtures with other type classes. ;;; (define-type-method (class :complex-subtypep-arg2) (type1 class2) (if (and (intersection-type-p type1) (> (count-if #'class-p (intersection-type-types type1)) 1)) (values nil nil) (invoke-complex-subtypep-arg1-method type1 class2 nil t))) (define-type-method (class :complex-subtypep-arg1) (type1 type2) (if (and (function-type-p type2) (eq type1 (specifier-type 'function)) (function-type-wild-args type2) (eq *wild-type* (function-type-returns type2))) (values t t) (values nil t))) (define-type-method (class :unparse) (type) (class-proper-name type)) ;;;; Built-in classes & class-of: ;;; ;;; The BUILT-IN-CLASSES list is a data structure which configures the ;;; creation of all the built-in classes. It contains all the info that we ;;; need to maintain the mapping between classes, compile-time types and ;;; run-time type codes. These options are defined: ;;; ;;; :TRANSLATION (default none) ;;; When this class is "parsed" as a type specifier, it is translated into ;;; the specified internal type representation, rather than being left as a ;;; class. This is used for types which we want to canonicalize to ;;; some other kind of type object because in general we want to be able to ;;; include more information than just the class (e.g. for numeric types). ;;; Default none. ;;; ;;; :ENUMERABLE (default NIL) ;;; The value of the :ENUMERABLE slot in the created class. Meaningless in ;;; translated classes. ;;; ;;; :STATE (default :SEALED) ;;; The value of CLASS-STATE which we want on completion, indicating ;;; whether subclasses can be created at run-time. ;;; ;;; :HIERARCHICAL (default T unless any of the inherits are non-hierarchical) ;;; True if we can assign this class a unique INHERITANCE-DEPTH. ;;; ;;; :CODES (default none) ;;; Run-time type codes which should be translated back to this class by ;;; CLASS-OF. Unspecified for abstract classes. ;;; ;;; :INHERITS (default this class & T) ;;; The class-precedence list for this class, with this class and T ;;; implicit. ;;; ;;; :DIRECT-SUPERCLASSES (default to head of CPL) ;;; List of the direct superclasses of this class. ;;; (defvar built-in-classes) (cold-load-init (setq built-in-classes '((t :state :read-only :translation t) (character :enumerable t :translation base-char) (base-char :enumerable t :inherits (character) :codes (#.vm:base-char-type)) (symbol :codes (#.vm:symbol-header-type)) (instance :state :read-only) (system-area-pointer :codes (#.vm:sap-type)) (weak-pointer :codes (#.vm:weak-pointer-type)) (scavenger-hook #+(or gengc gencgc) :codes #+(or gengc gencgc) (#.vm:scavenger-hook-type)) (code-component :codes (#.vm:code-header-type)) #-gengc (lra :codes (#.vm:return-pc-header-type)) (fdefn :codes (#.vm:fdefn-type)) (random-class) ; Used for unknown type codes. (function :codes (#.vm:byte-code-closure-type #.vm:byte-code-function-type #.vm:closure-header-type #.vm:function-header-type) :state :read-only) (funcallable-instance :inherits (function) :state :read-only) (collection :hierarchical nil :state :read-only) (explicit-key-collection :state :read-only :inherits (collection)) (mutable-collection :state :read-only :inherits (collection)) (mutable-explicit-key-collection :state :read-only :direct-superclasses (explicit-key-collection mutable-collection) :inherits (explicit-key-collection mutable-collection collection)) (generic-sequence :state :read-only :inherits (collection)) (mutable-sequence :state :read-only :direct-superclasses (mutable-collection generic-sequence) :inherits (mutable-collection generic-sequence collection)) (generic-array :state :read-only :inherits (mutable-sequence mutable-collection generic-sequence collection)) (generic-vector :state :read-only :inherits (generic-array mutable-sequence mutable-collection generic-sequence collection)) (array :translation array :codes (#.vm:complex-array-type) :inherits (generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array :translation simple-array :codes (#.vm:simple-array-type) :inherits (array generic-array mutable-sequence mutable-collection generic-sequence collection)) (sequence :translation (or cons (member nil) vector) :inherits (mutable-sequence mutable-collection generic-sequence collection)) (vector :translation vector :codes (#.vm:complex-vector-type) :direct-superclasses (array sequence generic-vector) :inherits (array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-vector :translation simple-vector :codes (#.vm:simple-vector-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (bit-vector :translation bit-vector :codes (#.vm:complex-bit-vector-type) :inherits (vector array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-bit-vector :translation simple-bit-vector :codes (#.vm:simple-bit-vector-type) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) :codes (#.vm:simple-array-unsigned-byte-2-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) :codes (#.vm:simple-array-unsigned-byte-4-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) :codes (#.vm:simple-array-unsigned-byte-8-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) :codes (#.vm:simple-array-unsigned-byte-16-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) :codes (#.vm:simple-array-unsigned-byte-32-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) :codes (#.vm:simple-array-signed-byte-8-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) :codes (#.vm:simple-array-signed-byte-16-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) :codes (#.vm:simple-array-signed-byte-30-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) :codes (#.vm:simple-array-signed-byte-32-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-single-float :translation (simple-array single-float (*)) :codes (#.vm:simple-array-single-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-double-float :translation (simple-array double-float (*)) :codes (#.vm:simple-array-double-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) #+long-float (simple-array-long-float :translation (simple-array long-float (*)) :codes (#.vm:simple-array-long-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) #+double-double (simple-array-double-double-float :translation (simple-array double-double-float (*)) :codes (#.vm::simple-array-double-double-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) :codes (#.vm:simple-array-complex-single-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) :codes (#.vm:simple-array-complex-double-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) #+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) :codes (#.vm:simple-array-complex-long-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) #+double-double (simple-array-complex-double-double-float :translation (simple-array (complex double-double-float) (*)) :codes (#.vm::simple-array-complex-double-double-float-type) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (generic-string :state :read-only :inherits (mutable-sequence mutable-collection generic-sequence collection)) (string :translation string :codes (#.vm:complex-string-type) :direct-superclasses (vector generic-string) :inherits (vector array sequence generic-vector generic-array generic-string mutable-sequence mutable-collection generic-sequence collection)) (simple-string :translation simple-string :codes (#.vm:simple-string-type) :direct-superclasses (string simple-array) :inherits (string vector generic-string simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (generic-number :state :read-only) (number :translation number :inherits (generic-number)) (complex :translation complex :inherits (number generic-number) :codes (#.vm:complex-type)) (complex-single-float :translation (complex single-float) :inherits (complex number generic-number) :codes (#.vm:complex-single-float-type)) (complex-double-float :translation (complex double-float) :inherits (complex number generic-number) :codes (#.vm:complex-double-float-type)) #+long-float (complex-long-float :translation (complex long-float) :inherits (complex number generic-number) :codes (#.vm:complex-long-float-type)) #+double-double (complex-double-double-float :translation (complex double-double-float) :inherits (complex number generic-number) :codes (#.vm::complex-double-double-float-type)) (real :translation real :inherits (number generic-number)) (float :translation float :inherits (real number generic-number)) (single-float :translation single-float :inherits (float real number generic-number) :codes (#.vm:single-float-type)) (double-float :translation double-float :inherits (float real number generic-number) :codes (#.vm:double-float-type)) #+long-float (long-float :translation long-float :inherits (float real number generic-number) :codes (#.vm:long-float-type)) #+double-double (double-double-float :translation double-double-float :inherits (float real number generic-number) :codes (#.vm::double-double-float-type)) (rational :translation rational :inherits (real number generic-number)) (ratio :translation (and rational (not integer)) :inherits (rational real number generic-number) :codes (#.vm:ratio-type)) (integer :translation integer :inherits (rational real number generic-number)) (fixnum :translation (integer #.vm:target-most-negative-fixnum #.vm:target-most-positive-fixnum) :inherits (integer rational real number generic-number) :codes (#.vm:even-fixnum-type #.vm:odd-fixnum-type)) (bignum :translation (or (integer * (#.vm:target-most-negative-fixnum)) (integer (#.vm:target-most-positive-fixnum) *)) :inherits (integer rational real number generic-number) :codes (#.vm:bignum-type)) (list :translation (or cons (member nil)) :inherits (sequence mutable-sequence mutable-collection generic-sequence collection)) (cons :translation cons :codes (#.vm:list-pointer-type) :inherits (list sequence mutable-sequence mutable-collection generic-sequence collection)) (null :translation (member nil) :inherits (symbol list sequence mutable-sequence mutable-collection generic-sequence collection) :direct-superclasses (symbol list)) (stream :state :read-only :depth 3 :inherits (instance))))) ;;; See also type-init.lisp where we finish setting up the translations for ;;; built-in types. ;;; (cold-load-init (dolist (x built-in-classes) (destructuring-bind (name &key (translation nil trans-p) inherits codes enumerable state (hierarchical t) depth (direct-superclasses (if inherits (list (car inherits)) '(t)))) x (declare (ignore codes state translation)) (let ((inherits (if (eq name 't) () (cons 't (reverse inherits)))) (class (make-built-in-class :enumerable enumerable :name name :translation (if trans-p :initializing nil) :direct-superclasses (if (eq name 't) () (mapcar #'find-class direct-superclasses))))) (setf (info type kind name) :primitive) (setf (class-cell-class (find-class-cell name)) class) (unless trans-p (setf (info type builtin name) class)) (let* ((inheritance-depth (if hierarchical (or depth (length inherits)) -1)) (inherit-layouts (map 'vector #'(lambda (x) (let ((super-layout (%class-layout (find-class x)))) (when (= (layout-inheritance-depth super-layout) -1) (setf inheritance-depth -1)) super-layout)) inherits))) (register-layout (find-layout name 0 inherit-layouts inheritance-depth) :invalidate nil)))))) ;;; Define temporary PCL standard-classes; these will be setup ;;; correctly and the lisp layout replaced by a PCL wrapper after PCL ;;; is loaded and the class defined. (cold-load-init (dolist (x '((fundamental-stream (t instance stream stream)) (stream:simple-stream (t instance stream)) (stream:single-channel-simple-stream (t instance stream stream:simple-stream)) (stream:dual-channel-simple-stream (t instance stream stream:simple-stream)) (stream:string-simple-stream (t instance stream stream:simple-stream)))) (let* ((name (first x)) (inherits (second x)) (class (make-standard-class :name name)) (class-cell (find-class-cell name))) (setf (class-cell-class class-cell) class) (setf (info type class name) class-cell) (setf (info type kind name) :instance) (let ((inherit-layouts (map 'vector #'(lambda (x) (%class-layout (find-class x))) inherits))) (register-layout (find-layout name 0 inherit-layouts -1) :invalidate nil))))) ;;; Now that we have set up the class heterarchy, seal the sealed classes. ;;; This must be done after the subclasses have been set up. ;;; (cold-load-init (dolist (x built-in-classes) (destructuring-bind (name &key (state :sealed) &allow-other-keys) x (setf (%class-state (find-class name)) state)))) ;;; A vector that maps type codes to layouts, used for quickly finding the ;;; layouts of built-in classes. ;;; (defvar built-in-class-codes) (cold-load-init (setq built-in-class-codes (let ((res (make-array 256 :initial-element '#.(%class-layout (find-class 'random-class))))) (dolist (x built-in-classes res) (destructuring-bind (name &key codes &allow-other-keys) x (let ((layout (%class-layout (find-class name)))) (dolist (code codes) (setf (svref res code) layout)))))))) ;;; LAYOUT-OF -- Exported ;;; ;;; Return the layout for an object. This is the basic operation for ;;; finding out the "type" of an object, and is used for generic function ;;; dispatch. The standard doesn't seem to say as much as it should about what ;;; this returns for built-in objects. For example, it seems that we must ;;; return NULL rather than LIST when X is NIL so that GF's can specialize on ;;; NULL. ;;; (declaim (inline layout-of)) (defun layout-of (x) (declare (optimize (speed 3) (safety 0))) (cond ((%instancep x) (%instance-layout x)) ((funcallable-instance-p x) (%funcallable-instance-layout x)) ((null x) '#.(%class-layout (find-class 'null))) (t (svref built-in-class-codes (get-type x))))) ;;; CLASS-OF -- Public ;;; (declaim (inline class-of)) (defun class-of (object) "Return the class of the supplied object, which may be any Lisp object, not just a CLOS STANDARD-OBJECT." (layout-class (layout-of object))) ;;;; Class definition/redefinition: ;;; MODIFY-CLASS -- Internal ;;; ;;; Called whenever we are altering a class. Clear type system caches and ;;; warn if read-only. ;;; (defun modify-class (class) (clear-type-caches) (when (member (%class-state class) '(:read-only :frozen)) (warn (intl:gettext "Modifing ~(~A~) class ~S; making it writable.") (%class-state class) (%class-name class)) (setf (%class-state class) nil))) ;;; INVALIDATE-LAYOUT -- Internal ;;; ;;; Mark a layout as invalid. Depth -1 causes unsafe structure type tests ;;; to fail. Remove class from all superclasses (might not be registered, so ;;; might not be in subclasses of the nominal superclasses.) ;;; (defun invalidate-layout (layout) (declare (type layout layout)) (setf (layout-invalid layout) :invalid) (setf (layout-inheritance-depth layout) -1) (let ((inherits (layout-inherits layout)) (class (layout-class layout))) (modify-class class) (dotimes (i (length inherits)) (let* ((super (svref inherits i)) (subs (%class-subclasses (layout-class super)))) (when subs (remhash class subs))))) (undefined-value)) ;;; REGISTER-LAYOUT -- Interface ;;; ;;; Record Layout as the layout for its class, adding it as a subtype of all ;;; superclasses. This is the operation that "installs" a layout for a class ;;; in the type system, clobbering any old layout. However, this does not ;;; modify the class namespace; that is a separate operation (think anonymous ;;; classes.) ;;; -- If INVALIDATE, then all the layouts for any old definition ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared. ;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be ;;; destructively modified to hold the same type information. ;;; (defun register-layout (layout &key (invalidate t) destruct-layout) (declare (type layout layout) (type (or layout null) destruct-layout)) (let* ((class (layout-class layout)) (class-layout (%class-layout class)) (subclasses (%class-subclasses class))) (assert (not (eq class-layout layout))) (when class-layout (modify-class class) (when subclasses (do-hash (c l subclasses) (modify-class c) (when invalidate (invalidate-layout l)))) (when invalidate (invalidate-layout class-layout) (setf (%class-subclasses class) nil))) (cond (destruct-layout (setf (layout-invalid destruct-layout) nil) (setf (layout-inherits destruct-layout) (layout-inherits layout)) (setf (layout-inheritance-depth destruct-layout) (layout-inheritance-depth layout)) (setf (layout-length destruct-layout) (layout-length layout)) (setf (layout-info destruct-layout) (layout-info layout)) (setf (%class-layout class) destruct-layout)) (t (setf (layout-invalid layout) nil) (setf (%class-layout class) layout))) (let ((inherits (layout-inherits layout))) (dotimes (i (length inherits)) (let* ((super (layout-class (svref inherits i))) (subclasses (or (%class-subclasses super) (setf (%class-subclasses super) (make-hash-table :test #'eq))))) (when (and (eq (%class-state super) :sealed) (not (gethash class subclasses))) (warn (intl:gettext "Subclassing sealed class ~S; unsealing it.") (%class-name super)) (setf (%class-state super) :read-only)) (setf (gethash class subclasses) (or destruct-layout layout)))))) (undefined-value)) ;;; LAYOUT-PROPER-NAME -- Internal ;;; (defun layout-proper-name (layout) (class-proper-name (layout-class layout))) ;;; REDEFINE-LAYOUT-WARNING -- Interface ;;; ;;; If layouts Old and New differ in any interesting way, then give a ;;; warning and return T. ;;; (defun redefine-layout-warning (old old-context new new-context) (declare (type layout old new) (simple-string old-context new-context)) (when (typep (layout-class old) 'undefined-class) (setf (layout-class old) (layout-class new))) (assert (eq (layout-class old) (layout-class new))) (let ((name (layout-proper-name old))) (or (let ((oldi (layout-inherits old)) (newi (layout-inherits new))) (or (when (mismatch oldi newi :key #'layout-proper-name) (warn (intl:gettext "Change in superclasses of class ~S:~% ~ ~A superclasses: ~S~% ~ ~A superclasses: ~S") name old-context (map 'list #'layout-proper-name oldi) new-context (map 'list #'layout-proper-name newi)) t) (let ((diff (mismatch oldi newi))) (when diff (warn (intl:gettext "In class ~S:~% ~ ~:(~A~) definition of superclass ~S incompatible with~% ~ ~A definition.") name old-context (layout-proper-name (svref oldi diff)) new-context) t)))) (let ((old-len (layout-length old)) (new-len (layout-length new))) (unless (= old-len new-len) (warn (intl:gettext "Change in instance length of class ~S:~% ~ ~A length: ~D~% ~ ~A length: ~D") name old-context old-len new-context new-len) t)) (when (/= (layout-inheritance-depth old) (layout-inheritance-depth new)) (warn (intl:gettext "Change in the inheritance structure of class ~S~% ~ between the ~A definition and the ~A definition.") name old-context new-context) t)))) ;;; FIND-LAYOUT -- Interface ;;; ;;; Used by the loader to forward-reference layouts for classes whose ;;; definitions may not have been loaded yet. This allows type tests to be ;;; loaded when the type definition hasn't been loaded yet. Name is the class ;;; name, Length is the length of instances, Inherits is a simple-vector of the ;;; layouts for the classes it inherits, and Depth is the Inheritance-Depth. ;;; ;;; If we can't find any existing layout, then we create a new one with the ;;; supplied information, storing it in *FORWARD-REFERENCED-LAYOUTS*. If we ;;; can find the layout, then return it, after checking for compatibility. If ;;; incompatible, we allow the layout to be replaced, altered or left alone. ;;; (defun find-layout (name length inherits depth) (declare (type index length) (simple-vector inherits) (type (or index (integer -1 -1)) depth)) (let* ((class (or (find-class name nil) (make-undefined-class name))) (old (or (%class-layout class) (gethash name *forward-referenced-layouts*))) (res (make-layout :class class :invalid :undefined :inherits inherits :inheritance-depth depth :length length))) (cond ((not old) (setf (gethash name *forward-referenced-layouts*) res)) ((not *type-system-initialized*) (setf (layout-class old) class) old) #-bootstrap-dynamic-extent ((redefine-layout-warning old "current" res "compile time") (restart-case (error (intl:gettext "Loading a reference to class ~S when the compile~ ~% time definition was incompatible with the current ~ one.") name) (continue () :report (lambda (stream) (write-string (intl:gettext "Invalidate current definition.") stream)) (warn (intl:gettext "New definition of ~S must be loaded eventually.") name) (invalidate-layout old) (setf (gethash name *forward-referenced-layouts*) res)) (clobber-it () :report (lambda (stream) (write-string (intl:gettext "Smash current layout, preserving old code.") stream)) (warn (intl:gettext "Any old ~S instances will be in a bad way.~@ I hope you know what you're doing...") name) (setf (layout-inherits old) inherits) (setf (layout-inheritance-depth old) depth) (setf (layout-length old) length) old) (use-current () :report (lambda (stream) (write-string (intl:gettext "Ignore the incompatibility, leave class alone.") stream)) (warn (intl:gettext "Assuming the current definition of ~S is correct, and~@ that the loaded code doesn't care about the ~ incompatibility.") name) old))) (t old)))) ;;; Class precedence lists ;;; topological-sort -- Public. ;;; ;;; Topologically sort the list of objects to meet a set of ordering ;;; constraints given by pairs (A . B) constraining A to precede B. When ;;; there are multiple objects to choose, the tie-breaker function is called ;;; with both the list of object to choose from and the reverse ordering built ;;; so far. ;;; (defun topological-sort (objects constraints tie-breaker) (declare (list objects constraints) (function tie-breaker)) (let ((obj-info (make-hash-table :size (length objects))) (free-objs nil) (result nil)) (dolist (constraint constraints) (let ((obj1 (car constraint)) (obj2 (cdr constraint))) (let ((info2 (gethash obj2 obj-info))) (if info2 (incf (first info2)) (setf (gethash obj2 obj-info) (list 1)))) (let ((info1 (gethash obj1 obj-info))) (if info1 (push obj2 (rest info1)) (setf (gethash obj1 obj-info) (list 0 obj2)))))) (dolist (obj objects) (let ((info (gethash obj obj-info))) (when (or (not info) (zerop (first info))) (push obj free-objs)))) (loop (flet ((next-result (obj) (push obj result) (dolist (successor (rest (gethash obj obj-info))) (let* ((successor-info (gethash successor obj-info)) (count (1- (first successor-info)))) (setf (first successor-info) count) (when (zerop count) (push successor free-objs)))))) (cond ((endp free-objs) (do-hash (obj info obj-info) (unless (zerop (first info)) (error (intl:gettext "Topological sort failed due to constraint on ~S.") obj))) (return (nreverse result))) ((endp (rest free-objs)) (next-result (pop free-objs))) (t (let ((obj (funcall tie-breaker free-objs result))) (setf free-objs (remove obj free-objs)) (next-result obj)))))))) ;;; std-compute-class-precedence-list -- Internal. ;;; ;;; Standard class precedence list computation. ;;; (defun std-compute-class-precedence-list (class) (let ((classes nil) (constraints nil)) (labels ((note-class (class) (unless (member class classes) (push class classes) (let ((superclasses (%class-direct-superclasses class))) (do ((prev class) (rest superclasses (rest rest))) ((endp rest)) (let ((next (first rest))) (push (cons prev next) constraints) (setf prev next))) (dolist (class superclasses) (note-class class))))) (std-cpl-tie-breaker (free-classes rev-cpl) (dolist (class rev-cpl (first free-classes)) (let* ((superclasses (%class-direct-superclasses class)) (intersection (intersection free-classes superclasses))) (when intersection (return (first intersection))))))) (note-class class) (topological-sort classes constraints #'std-cpl-tie-breaker)))) ;;; PCL stuff: (defstruct (std-class (:include class))) (defstruct (standard-class (:include std-class))) (defstruct (random-pcl-class (:include std-class))) ;;;; Cold loading initializations. (defun class-finalize () (dolist (layout *layout-hash-inits*) (initialize-layout-hash layout)) (makunbound '*layout-hash-inits*) (do-hash (name layout *forward-referenced-layouts*) (let ((class (find-class name nil))) (cond ((not class) (setf (layout-class layout) (make-undefined-class name))) ((eq (%class-layout class) layout) (remhash name *forward-referenced-layouts*)) (t (warn (intl:gettext "Something strange with forward layout for ~S:~% ~S") name layout)))))) (emit-cold-load-defuns "CLASS") cmucl-21a/src/code/clx-ext.lisp000066400000000000000000000672441260377556400165540ustar00rootroot00000000000000;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/clx-ext.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains code to extend CLX in the CMU Common Lisp environment. ;;; ;;; Written by Bill Chiles and Chris Hoover. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(open-clx-display with-clx-event-handling enable-clx-event-handling disable-clx-event-handling object-set-event-handler default-clx-event-handler flush-display-events carefully-add-font-paths serve-key-press serve-key-release serve-button-press serve-button-release serve-motion-notify serve-enter-notify serve-leave-notify serve-focus-in serve-focus-out serve-exposure serve-graphics-exposure serve-no-exposure serve-visibility-notify serve-create-notify serve-destroy-notify serve-unmap-notify serve-map-notify serve-map-request serve-reparent-notify serve-configure-notify serve-gravity-notify serve-resize-request serve-configure-request serve-circulate-notify serve-circulate-request serve-property-notify serve-selection-clear serve-selection-request serve-selection-notify serve-colormap-notify serve-client-message)) ;;;; OPEN-CLX-DISPLAY. ;;; New version to interface with "telent-clx". #+(and) (defun open-clx-display (&optional display-name) "Open a connection to DISPLAY-NAME if supplied, or to the appropriate default display as given by GET-DEFAULT-DISPLAY otherwise." (destructuring-bind (host display screen protocol) (xlib::get-default-display display-name) (let ((display (xlib:open-display host :display display :protocol protocol))) (values display (setf (xlib:display-default-screen display) (nth screen (xlib:display-roots display))))))) #-(and) (defun open-clx-display (&optional (string (cdr (assoc :display *environment-list* :test #'eq)))) "Parses the display specifier STRING, including display and screen numbers. STRING defaults to the value of the DISPLAY environment variable. If STRING is non-nil, and any fields are missing in the specification, this signals an error. If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN to that screen since CLX initializes this form to the first of XLIB:SCREEN-ROOTS. Return the display and screen objects." (when string (let* ((string (coerce string 'simple-string)) (length (length string)) (host-name "") (display-num nil) (screen-num nil)) (declare (simple-string string)) (let ((colon (position #\: string :test #'char=))) (cond ((null colon) (error (intl:gettext "Missing display number in DISPLAY environment variable."))) (t (unless (zerop colon) (setf host-name (subseq string 0 colon))) (let* ((start (1+ colon)) (first-dot (position #\. string :test #'char= :start start))) (cond ((= start (or first-dot length)) (error (intl:gettext "Badly formed display number in DISPLAY ~ environment variable."))) ((null first-dot) (setf display-num (parse-integer string :start start))) (t (setf display-num (parse-integer string :start start :end first-dot)) (let* ((start (1+ first-dot)) (second-dot (position #\. string :test #'char= :start start))) (cond ((= start (or second-dot length)) (error (intl:gettext "Badly formed screen number in ~ DISPLAY environment variable."))) (t (setf screen-num (parse-integer string :start start :end second-dot))))))))))) (let ((display (xlib:open-display host-name :display display-num))) (when screen-num (let* ((screens (xlib:display-roots display)) (num-screens (length screens))) (when (>= screen-num num-screens) (xlib:close-display display) (error (intl:gettext "No such screen number (~D).") screen-num)) (setf (xlib:display-default-screen display) (elt screens screen-num)))) (values display (xlib:display-default-screen display)))))) ;;;; Font Path Manipulation (defun carefully-add-font-paths (display font-pathnames &optional (operation :append)) "Adds the list of font pathnames, Font-Pathnames, to the font path of the server Display but does so carefully by checking to make sure that the font pathnames are not already on the server's font path. If any of the font pathnames are on the server's font path, they will remain in their current positions. Operation may be specified as either :prepend or :append and specifies whether to add the additional font pathnames to the beginning or the end of the server's original font path." (let ((font-path (xlib:font-path display)) (result ())) (dolist (elt font-pathnames) (enumerate-search-list (pathname elt) (lisp::enumerate-matches (name pathname) (unless (member name font-path :test #'string=) (push name result))))) (when result (ecase operation (:prepend (setf (xlib:font-path display) (revappend result font-path))) (:append (setf (xlib:font-path display) (append font-path (nreverse result)))))))) ;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT. (defvar *clx-fds-to-displays* (make-hash-table :test #'eql) "This is a hash table that maps CLX file descriptors to CLX display structures. For every CLX file descriptor know to SYSTEM:SERVE-EVENT, there must be a mapping from that file descriptor to its CLX display structure when events are handled via SYSTEM:SERVE-EVENT.") (defmacro with-clx-event-handling ((display handler) &rest body) "Evaluates body in a context where events are handled for the display by calling handler on the display. This destroys any previously established handler for display." `(unwind-protect (progn (enable-clx-event-handling ,display ,handler) ,@body) (disable-clx-event-handling ,display))) ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in ;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have ;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows ;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a ;;; file descriptor, the file descriptor is also mapped to the display in ;;; *clx-fds-to-displays*, so the user's handler can be called on the display. ;;; (defun enable-clx-event-handling (display handler) "After calling this, when SYSTEM:SERVE-EVENT notices input on display's connection to the X11 server, handler is called on the display. Handler is invoked in a dynamic context with an error handler bound that will flush all events from the display and return. By returning, it declines to handle the error, but it will have cleared all events; thus, entering the debugger will not result in infinite errors due to streams that wait via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same display establishes handler as a new handler, replacing any previous one for display." (check-type display xlib:display) (let ((change-handler (assoc display *display-event-handlers*))) (if change-handler (setf (cdr change-handler) handler) (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) (system:add-fd-handler fd :input #'call-display-event-handler) (setf (gethash fd *clx-fds-to-displays*) display) (push (cons display handler) *display-event-handlers*))))) ;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps ;;; the display to its handler. If we can't find the display, we remove the ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the ;;; display from *display-event-handlers*. This is necessary to try to keep ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and ;;; over. This is possible since many CMU Common Lisp streams loop over ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are ;;; possible. ;;; (defun call-display-event-handler (file-descriptor) (let ((display (gethash file-descriptor *clx-fds-to-displays*))) (unless display (system:invalidate-descriptor file-descriptor) (setf *display-event-handlers* (delete file-descriptor *display-event-handlers* :key #'(lambda (d/h) (fd-stream-fd (xlib::display-input-stream (car d/h)))))) (error (intl:gettext "File descriptor ~S not associated with any CLX display.~%~ It has been removed from system:serve-event's knowledge.") file-descriptor)) (let ((handler (cdr (assoc display *display-event-handlers*)))) (unless handler (flush-display-events display) (error (intl:gettext "Display ~S not associated with any event handler.") display)) (handler-bind ((error #'(lambda (condx) (declare (ignore condx)) (flush-display-events display)))) (funcall handler display))))) (defun disable-clx-event-handling (display) "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING." (setf *display-event-handlers* (delete display *display-event-handlers* :key #'car)) (let ((fd (fd-stream-fd (xlib::display-input-stream display)))) (remhash fd *clx-fds-to-displays*) (system:invalidate-descriptor fd))) ;;;; Object set event handling. ;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear ;;; events on the display before signalling any errors. This is necessary ;;; since reading on certain CMU Common Lisp streams involves SERVER, and ;;; getting an error while trying to handle an event causes repeated attempts ;;; to handle the same event. ;;; (defvar *process-clx-event-display* nil) (defvar *object-set-event-handler-print* nil) (declaim (declaration values)) (defun object-set-event-handler (display) "This display event handler uses object sets to map event windows cross event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots of each event, calling the handlers on all these values in addition to the event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble is an event keyword name for the exact order of arguments. :mapping-notify and :keymap-notify events are ignored since they do not occur on any particular window. After calling a handler, each branch returns t to discard the event. While the handler is executing, all errors go through a handler that flushes all the display's events and returns. This prevents infinite errors since the debug and terminal streams loop over SYSTEM:SERVE-EVENT. This function returns t if there were some event to handle, nil otherwise. It returns immediately if there is no event to handle." (macrolet ((dispatch (event-key &rest args) `(multiple-value-bind (object object-set) (lisp::map-xwindow event-window) (unless object (cond ((not (typep event-window 'xlib:window)) (xlib:discard-current-event display) (warn (intl:gettext "Discarding ~S event on non-window ~S.") ,event-key event-window) (return-from object-set-event-handler nil)) (t (flush-display-events display) (error (intl:gettext "~S not a known X window.~%~ Received event ~S.") event-window ,event-key)))) (handler-bind ((error #'(lambda (condx) (declare (ignore condx)) (flush-display-events display)))) (when *object-set-event-handler-print* (print ,event-key) (force-output)) (funcall (gethash ,event-key (lisp::object-set-table object-set) (lisp::object-set-default-handler object-set)) object ,event-key ,@args)) (setf result t)))) (let ((*process-clx-event-display* display) (result nil)) (xlib:event-case (display :timeout 0) ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE) (event-key event-window root child same-screen-p x y root-x root-y state time code send-event-p) (dispatch event-key event-window root child same-screen-p x y root-x root-y state time code send-event-p)) (:MOTION-NOTIFY (event-window root child same-screen-p x y root-x root-y state time hint-p send-event-p) (dispatch :motion-notify event-window root child same-screen-p x y root-x root-y state time hint-p send-event-p)) (:ENTER-NOTIFY (event-window root child same-screen-p x y root-x root-y state time mode kind send-event-p) (dispatch :enter-notify event-window root child same-screen-p x y root-x root-y state time mode kind send-event-p)) (:LEAVE-NOTIFY (event-window root child same-screen-p x y root-x root-y state time mode kind send-event-p) (dispatch :leave-notify event-window root child same-screen-p x y root-x root-y state time mode kind send-event-p)) (:EXPOSURE (event-window x y width height count send-event-p) (dispatch :exposure event-window x y width height count send-event-p)) (:GRAPHICS-EXPOSURE (event-window x y width height count major minor send-event-p) (dispatch :graphics-exposure event-window x y width height count major minor send-event-p)) (:NO-EXPOSURE (event-window major minor send-event-p) (dispatch :no-exposure event-window major minor send-event-p)) (:FOCUS-IN (event-window mode kind send-event-p) (dispatch :focus-in event-window mode kind send-event-p)) (:FOCUS-OUT (event-window mode kind send-event-p) (dispatch :focus-out event-window mode kind send-event-p)) (:KEYMAP-NOTIFY () (warn (intl:gettext "Ignoring keymap notify event.")) (when *object-set-event-handler-print* (print :keymap-notify) (force-output)) (setf result t)) (:VISIBILITY-NOTIFY (event-window state send-event-p) (dispatch :visibility-notify event-window state send-event-p)) (:CREATE-NOTIFY (event-window window x y width height border-width override-redirect-p send-event-p) (dispatch :create-notify event-window window x y width height border-width override-redirect-p send-event-p)) (:DESTROY-NOTIFY (event-window window send-event-p) (dispatch :destroy-notify event-window window send-event-p)) (:UNMAP-NOTIFY (event-window window configure-p send-event-p) (dispatch :unmap-notify event-window window configure-p send-event-p)) (:MAP-NOTIFY (event-window window override-redirect-p send-event-p) (dispatch :map-notify event-window window override-redirect-p send-event-p)) (:MAP-REQUEST (event-window window send-event-p) (dispatch :map-request event-window window send-event-p)) (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p send-event-p) (dispatch :reparent-notify event-window window parent x y override-redirect-p send-event-p)) (:CONFIGURE-NOTIFY (event-window window x y width height border-width above-sibling override-redirect-p send-event-p) (dispatch :configure-notify event-window window x y width height border-width above-sibling override-redirect-p send-event-p)) (:GRAVITY-NOTIFY (event-window window x y send-event-p) (dispatch :gravity-notify event-window window x y send-event-p)) (:RESIZE-REQUEST (event-window width height send-event-p) (dispatch :resize-request event-window width height send-event-p)) (:CONFIGURE-REQUEST (event-window window x y width height border-width stack-mode above-sibling value-mask send-event-p) (dispatch :configure-request event-window window x y width height border-width stack-mode above-sibling value-mask send-event-p)) (:CIRCULATE-NOTIFY (event-window window place send-event-p) (dispatch :circulate-notify event-window window place send-event-p)) (:CIRCULATE-REQUEST (event-window window place send-event-p) (dispatch :circulate-request event-window window place send-event-p)) (:PROPERTY-NOTIFY (event-window atom state time send-event-p) (dispatch :property-notify event-window atom state time send-event-p)) (:SELECTION-CLEAR (event-window selection time send-event-p) (dispatch :selection-notify event-window selection time send-event-p)) (:SELECTION-REQUEST (event-window requestor selection target property time send-event-p) (dispatch :selection-request event-window requestor selection target property time send-event-p)) (:SELECTION-NOTIFY (event-window selection target property time send-event-p) (dispatch :selection-notify event-window selection target property time send-event-p)) (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p) (dispatch :colormap-notify event-window colormap new-p installed-p send-event-p)) (:MAPPING-NOTIFY (request) (warn (intl:gettext "Ignoring mapping notify event -- ~S.") request) (when *object-set-event-handler-print* (print :mapping-notify) (force-output)) (setf result t)) (:CLIENT-MESSAGE (event-window format data send-event-p) (dispatch :client-message event-window format data send-event-p))) result))) (defun default-clx-event-handler (object event-key event-window &rest ignore) (declare (ignore ignore)) (flush-display-events *process-clx-event-display*) (error (intl:gettext "No handler for event type ~S on ~S in ~S.") event-key object (lisp::map-xwindow event-window))) (defun flush-display-events (display) "Dumps all the events in display's event queue including the current one in case this is called from within XLIB:EVENT-CASE, etc." (xlib:discard-current-event display) (xlib:event-case (display :discard-p t :timeout 0) (t () nil))) ;;;; Key and button service. (defun serve-key-press (object-set fun) "Associate a method in the object-set with :key-press events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and send-event-p." (setf (gethash :key-press (lisp::object-set-table object-set)) fun)) (defun serve-key-release (object-set fun) "Associate a method in the object-set with :key-release events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and send-event-p." (setf (gethash :key-release (lisp::object-set-table object-set)) fun)) (defun serve-button-press (object-set fun) "Associate a method in the object-set with :button-press events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and send-event-p." (setf (gethash :button-press (lisp::object-set-table object-set)) fun)) (defun serve-button-release (object-set fun) "Associate a method in the object-set with :button-release events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and send-event-p." (setf (gethash :button-release (lisp::object-set-table object-set)) fun)) ;;;; Mouse service. (defun serve-motion-notify (object-set fun) "Associate a method in the object-set with :motion-notify events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and send-event-p." (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun)) (defun serve-enter-notify (object-set fun) "Associate a method in the object-set with :enter-notify events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, and send-event-p." (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun)) (defun serve-leave-notify (object-set fun) "Associate a method in the object-set with :leave-notify events. The method is called on the object the event occurred, event key, event window, root, child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind, and send-event-p." (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun)) ;;;; Keyboard service. (defun serve-focus-in (object-set fun) "Associate a method in the object-set with :focus-in events. The method is called on the object the event occurred, event key, event window, mode, kind, and send-event-p." (setf (gethash :focus-in (lisp::object-set-table object-set)) fun)) (defun serve-focus-out (object-set fun) "Associate a method in the object-set with :focus-out events. The method is called on the object the event occurred, event key, event window, mode, kind, and send-event-p." (setf (gethash :focus-out (lisp::object-set-table object-set)) fun)) ;;;; Exposure service. (defun serve-exposure (object-set fun) "Associate a method in the object-set with :exposure events. The method is called on the object the event occurred, event key, event window, x, y, width, height, count, and send-event-p." (setf (gethash :exposure (lisp::object-set-table object-set)) fun)) (defun serve-graphics-exposure (object-set fun) "Associate a method in the object-set with :graphics-exposure events. The method is called on the object the event occurred, event key, event window, x, y, width, height, count, major, minor, and send-event-p." (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun)) (defun serve-no-exposure (object-set fun) "Associate a method in the object-set with :no-exposure events. The method is called on the object the event occurred, event key, event window, major, minor, and send-event-p." (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun)) ;;;; Structure service. (defun serve-visibility-notify (object-set fun) "Associate a method in the object-set with :visibility-notify events. The method is called on the object the event occurred, event key, event window, state, and send-event-p." (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun)) (defun serve-create-notify (object-set fun) "Associate a method in the object-set with :create-notify events. The method is called on the object the event occurred, event key, event window, window, x, y, width, height, border-width, override-redirect-p, and send-event-p." (setf (gethash :create-notify (lisp::object-set-table object-set)) fun)) (defun serve-destroy-notify (object-set fun) "Associate a method in the object-set with :destroy-notify events. The method is called on the object the event occurred, event key, event window, window, and send-event-p." (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun)) (defun serve-unmap-notify (object-set fun) "Associate a method in the object-set with :unmap-notify events. The method is called on the object the event occurred, event key, event window, window, configure-p, and send-event-p." (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun)) (defun serve-map-notify (object-set fun) "Associate a method in the object-set with :map-notify events. The method is called on the object the event occurred, event key, event window, window, override-redirect-p, and send-event-p." (setf (gethash :map-notify (lisp::object-set-table object-set)) fun)) (defun serve-map-request (object-set fun) "Associate a method in the object-set with :map-request events. The method is called on the object the event occurred, event key, event window, window, and send-event-p." (setf (gethash :map-request (lisp::object-set-table object-set)) fun)) (defun serve-reparent-notify (object-set fun) "Associate a method in the object-set with :reparent-notify events. The method is called on the object the event occurred, event key, event window, window, parent, x, y, override-redirect-p, and send-event-p." (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun)) (defun serve-configure-notify (object-set fun) "Associate a method in the object-set with :configure-notify events. The method is called on the object the event occurred, event key, event window, window, x, y, width, height, border-width, above-sibling, override-redirect-p, and send-event-p." (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun)) (defun serve-gravity-notify (object-set fun) "Associate a method in the object-set with :gravity-notify events. The method is called on the object the event occurred, event key, event window, window, x, y, and send-event-p." (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun)) (defun serve-resize-request (object-set fun) "Associate a method in the object-set with :resize-request events. The method is called on the object the event occurred, event key, event window, width, height, and send-event-p." (setf (gethash :resize-request (lisp::object-set-table object-set)) fun)) (defun serve-configure-request (object-set fun) "Associate a method in the object-set with :configure-request events. The method is called on the object the event occurred, event key, event window, window, x, y, width, height, border-width, stack-mode, above-sibling, value-mask, and send-event-p." (setf (gethash :configure-request (lisp::object-set-table object-set)) fun)) (defun serve-circulate-notify (object-set fun) "Associate a method in the object-set with :circulate-notify events. The method is called on the object the event occurred, event key, event window, window, place, and send-event-p." (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun)) (defun serve-circulate-request (object-set fun) "Associate a method in the object-set with :circulate-request events. The method is called on the object the event occurred, event key, event window, window, place, and send-event-p." (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun)) ;;;; Misc. service. (defun serve-property-notify (object-set fun) "Associate a method in the object-set with :property-notify events. The method is called on the object the event occurred, event key, event window, atom, state, time, and send-event-p." (setf (gethash :property-notify (lisp::object-set-table object-set)) fun)) (defun serve-selection-clear (object-set fun) "Associate a method in the object-set with :selection-clear events. The method is called on the object the event occurred, event key, event window, selection, time, and send-event-p." (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun)) (defun serve-selection-request (object-set fun) "Associate a method in the object-set with :selection-request events. The method is called on the object the event occurred, event key, event window, requestor, selection, target, property, time, and send-event-p." (setf (gethash :selection-request (lisp::object-set-table object-set)) fun)) (defun serve-selection-notify (object-set fun) "Associate a method in the object-set with :selection-notify events. The method is called on the object the event occurred, event key, event window, selection, target, property, time, and send-event-p." (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun)) (defun serve-colormap-notify (object-set fun) "Associate a method in the object-set with :colormap-notify events. The method is called on the object the event occurred, event key, event window, colormap, new-p, installed-p, and send-event-p." (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun)) (defun serve-client-message (object-set fun) "Associate a method in the object-set with :client-message events. The method is called on the object the event occurred, event key, event window, format, data, and send-event-p." (setf (gethash :client-message (lisp::object-set-table object-set)) fun)) cmucl-21a/src/code/cmu-site.lisp000066400000000000000000000012301260377556400166750ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: System -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/cmu-site.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Site specific initialization for CMU. This can be used as a template for ;;; non-cmu "library:site-init" files. ;;; (in-package "SYSTEM") (setq *short-site-name* "CMU-SCS") (setq *long-site-name* "Carnegie-Mellon University School of Computer Science") cmucl-21a/src/code/commandline.lisp000066400000000000000000000316211260377556400174440ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/commandline.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stuff to eat the command line passed to us from the shell. ;;; Written by Bill Chiles. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(*command-line-application-arguments* *command-line-words* *command-line-switches* *command-switch-demons* *command-line-utility-name* *command-line-strings* *batch-mode* cmd-switch-string command-line-switch-p cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch defswitch cmd-switch-arg get-command-line-switch)) (defvar *command-line-application-arguments* () "A list of all the command line arguments after --") (defvar *command-line-switches* () "A list of cmd-switch's representing the arguments used to invoke this process.") (defvar *command-line-utility-name* "" "The string name that was used to invoke this process.") (defvar *command-line-words* () "A list of words between the utility name and the first switch.") (defvar *command-line-strings* () "A list of strings obtained from the command line that invoked this process.") (defvar *command-switch-demons* () "An Alist of (\"argument-name\" . demon-function)") (defvar *batch-mode* nil "When True runs lisp with its input coming from standard-input. If an error is detected returns error code 1, otherwise 0.") (defstruct (command-line-switch (:conc-name cmd-switch-) (:constructor make-cmd-switch (name value words)) (:print-function print-command-line-switch)) name ;the name of the switch value ;the value of that switch words ;random words dangling between switches assigned to the ;preceeding switch ) (defun print-command-line-switch (object stream n) (declare (ignore n)) (write-string "#" stream)) ;;;; Processing the command strings. (defun process-command-strings () (setq *command-line-words* nil) (setq *command-line-switches* nil) (let ((cmd-strings lisp::lisp-command-line-list) str) (declare (special lisp::lisp-command-line-list)) ;; Set some initial variables. ;; (setf *command-line-strings* (copy-list lisp::lisp-command-line-list)) (setf *command-line-utility-name* (pop cmd-strings)) (setq str (pop cmd-strings)) ;; Set initial command line words. ;; (loop (unless str (return nil)) (unless (zerop (length (the simple-string str))) (when (char= (schar str 0) #\-) (setq *command-line-words* (reverse *command-line-words*)) (return nil)) (push str *command-line-words*)) (setq str (pop cmd-strings))) (when (string= str "--") ;; Handle the special case where -- is the first option. The ;; code below interprets that incorrectly and I (rtoy) don't ;; want to mess with that, so just set up ;; *command-line-application-arguments* and return. (setf *command-line-application-arguments* cmd-strings) (return-from process-command-strings nil)) ;; Set command line switches. ;; (loop (unless str (return (setf *command-line-switches* (nreverse *command-line-switches*)))) (let* ((position (position #\= (the simple-string str) :test #'char=)) (switch (subseq (the simple-string str) 1 position)) (value (if position (subseq (the simple-string str) (1+ position) (length (the simple-string str)))))) (setq str (pop cmd-strings)) ;; Set this switch's words until the next switch. ;; (let (word-list) (loop (unless str (push (make-cmd-switch switch value (nreverse word-list)) *command-line-switches*) (return nil)) (unless (zerop (length (the simple-string str))) (when (char= #\- (schar str 0)) (push (make-cmd-switch switch value (nreverse word-list)) *command-line-switches*) (when (and (= (length str) 2) (char= #\- (schar str 1))) ;; Gather up everything after --, and exit. (setf *command-line-application-arguments* cmd-strings) (setf str nil)) (return nil)) (push str word-list)) (setq str (pop cmd-strings)))))))) (defun get-command-line-switch (sname) "Accepts the name of a switch as a string and returns the value of the switch. If no value was specified, then any following words are returned. If there are no following words, then t is returned. If the switch was not specified, then nil is returned." (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname)) (switch (find name *command-line-switches* :test #'string-equal :key #'cmd-switch-name))) (when switch (or (cmd-switch-value switch) (cmd-switch-words switch) T)))) ;;;; Defining Switches and invoking demons. (defvar *complain-about-illegal-switches* t "When set, invoking switch demons complains about illegal switches that have not been defined with DEFSWITCH.") ;;; This is a list of lists consisting of the legal switch names, ;;; switch description, and argument description. The description and ;;; argument description can be NIL. (Should probably do something ;;; better, but this is good enough for the little bit of processing ;;; that we need.) DEFSWITCH sets this, and INVOKE-SWITCH-DEMONS ;;; makes sure all the switches it sees are on this list. ;;; (defvar *legal-cmd-line-switches* nil) ;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*. For ;;; each switch, it checks to see if there is a switch demon with the same ;;; name. If there is, then that demon is called as a function on the switch. ;;; (defun invoke-switch-demons (&optional (switches *command-line-switches*) (demons *command-switch-demons*)) (flet ((invoke-demon (switch) (let* ((name (cmd-switch-name switch)) (demon (cdr (assoc name demons :test #'string-equal)))) (cond (demon (funcall demon switch)) ((or (member name *legal-cmd-line-switches* :test #'string-equal :key #'car) (not *complain-about-illegal-switches*))) (t (warn (intl:gettext "~S is an illegal switch") switch))) (lisp::finish-standard-output-streams)))) ;; We want to process -help (or --help) first, if it's given. ;; Since we're asking for help, we don't want to process any of ;; the other switches. (let ((maybe-help (or (find "help" switches :key #'cmd-switch-name :test #'string-equal) (find "-help" switches :key #'cmd-switch-name :test #'string-equal)))) (if maybe-help (invoke-demon maybe-help) (dolist (switch switches t) (invoke-demon switch)))))) (defmacro defswitch (name &optional function docstring arg-name) "Associates function with the switch name in *command-switch-demons*. Name is a simple-string that does not begin with a hyphen, unless the switch name really does begin with one. Function is optional, but defining the switch is necessary to keep invoking switch demons from complaining about illegal switches. This can be inhibited with *complain-about-illegal-switches*. The optional arguments, arg-name and docstring, are used by -help to describe the switch. Arg-name is a string naming the argument (if any) for the switch. Docstring describe the switch." (let ((gname (gensym)) (gfunction (gensym))) (when docstring (intl::note-translatable intl::*default-domain* docstring)) (when arg-name (intl::note-translatable intl::*default-domain* arg-name)) `(let ((,gname ,name) (,gfunction ,function)) (check-type ,gname simple-string) (check-type ,gfunction (or symbol function) (intl:gettext "a symbol or function")) (push (list ,gname ,docstring ,arg-name) *legal-cmd-line-switches*) (when ,gfunction (push (cons ,gname ,gfunction) *command-switch-demons*))))) (defun eval-switch-demon (switch) (let ((cmds (cmd-switch-arg switch))) (do ((length (length cmds)) (start 0)) ((>= start length)) (multiple-value-bind (form next) (read-from-string cmds nil nil :start start) (eval form) (lisp::finish-standard-output-streams) (setf start next))))) ;; Docstrings should have lines longer than 72 characters so that we ;; can print out the docstrings nicely on one line for help. ;; | <-- char 72 (defswitch "eval" #'eval-switch-demon "Evaluate the specified Lisp expression during the start up sequence. the value of the form will not be printed unless it is wrapped in a form that does output." "expression") (defun load-switch-demon (switch) (load (cmd-switch-arg switch))) (defswitch "load" #'load-switch-demon "Loads the specified file into Lisp before entering Lisp's read-eval-print loop." "filename") (defun cmd-switch-arg (switch) (or (cmd-switch-value switch) (car (cmd-switch-words switch)) (car *command-line-words*))) (defswitch "core" nil "Specifies the suspended Lisp image ('core' file) to start up" "corefile") (defswitch "init" nil "Specifies the name of a file containing user customizations that is to be loaded each time Lisp starts up (default ~/init or ~/.cmucl-init.lisp). The loader loads any existing compiled binary or the lisp source if none." "filename") (defswitch "noinit" nil "Suppresses loading of the init file and also prevents -edit from loading the Hemlock init file.") (defswitch "nositeinit" nil "Suppresses loading of the site-init site specific initialization file.") (defswitch "hinit" nil "Specifies the name of the Hemlock init file (default ~/hemlock-init or ~/.hemlock-init), which is loaded only when Hemlock is started." "filename") (defswitch "batch" nil "Causes Lisp to run in batch mode where all input is directed from standard-input. A unix return code of 0 is returned upon encountering an EOF, while any unhandled error condition will cause an immediate exit with a return code of 1, instead of entering the debugger.") (defswitch "dynamic-space-size" nil "Specifies the number of megabytes that should be allocated to the heap. If not specified, a platform-specific default is used. The actual maximum allowed heap size is platform-specific." "megabytes") (defswitch "read-only-space-size" nil "Specifies the number of megabytes that should be allocated for the read-only space. If not specified, a platform-specific default is used. The actual maximum allowed read-only size is platform-specific." "megabytes") (defswitch "static-space-size" nil "Specifies the number of megabytes that should be allocated for the static space. If not specified, a platform-specific default is used. The actual maximum allowed static space size is platform-specific." "megabytes") (defswitch "control-stack-size" nil "Specifies the number of megabytes that should be allocated for the control stack. If not specified, a platform-specific default is used. The actual maximum allowed control stack size is platform-specific." "megabytes") (defswitch "binding-stack-size" nil "Specifies the number of megabytes that should be allocated for the binding stack. If not specified, a platform-specific default is used. The actual maximum allowed binding stack size is platform-specific." "megabytes") (defswitch "lib" nil "A colon-separated list of directories to be used for the library: search-list." "libpath") (defswitch "quiet" nil "Causes Lisp to start up silently, disabling printing of the herald and causing most unnecessary noise, like GC messages,load messages, etc. to be suppressed.") (defswitch "debug-lisp-search" nil "Enables printing of messages indication how CMUCL is searching for its default core file.") (defswitch "unidata" nil "Specify the unidata.bin file to be used." "filename") (defun help-switch-demon (switch) (declare (ignore switch)) (format t (intl:gettext "~&Usage: ~A ~2%") *command-line-utility-name*) (dolist (s (sort *legal-cmd-line-switches* #'string< :key #'car)) (destructuring-bind (name doc arg) s (format t " -~A ~@[~A~]~%" name (if arg (intl:gettext arg))) ;; Poor man's formatting of the help string (with-input-from-string (stream (intl:gettext doc)) (loop for line = (read-line stream nil nil) while line do (format t "~8T~A~%" line))))) (ext:quit)) (defswitch "help" #'help-switch-demon "Print out the command line options and exit") (defswitch "-help" #'help-switch-demon "Same as -help.") cmucl-21a/src/code/cprofile.lisp000066400000000000000000000321421260377556400167600ustar00rootroot00000000000000;;; -*- Package: CPROFILE -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/cprofile.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains run-time support for collecting dynamic profiling ;;; information from code instrumented by the compiler. ;;; (intl:textdomain "cmucl") (defpackage "CPROFILE" (:use "C" "DI" "KERNEL" "EXTENSIONS" "LISP" "SYSTEM")) (in-package "C") (export '(dyncount-info dyncount-info-p) "C") (in-package "CPROFILE") (eval-when (compile) (when *collect-dynamic-statistics* (error (intl:gettext "You don't want to compile this file with profiling.")))) ;;; Represents a single high-cost code object we've pulled out of memory. ;;; (defstruct (selection-elt (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :type t :identity t))))) ;; ;; The code-object we're collecting info for. (code nil) ;; ;; The Dyncount-Info for this object (the first constant.) (info nil :type (or dyncount-info null)) ;; ;; The total cost associated with this code object. (cost 0d0 :type double-float) ;; ;; Remaining slots only filled in when we have definitely selected this ;; object... ;; ;; A copy of the counts vector (so the results don't get modified.) (counts nil :type (or (simple-array (unsigned-byte 32) (*)) null)) ;; ;; A list of lists ((debug-function cost first-index) for all the functions ;; in this object, where cost is the total cost for this function and ;; first-index is the index in costs/counts of the first block in this ;; function. (functions nil :type list)) ;;; Represents a collection of the N most expensive code objects. ;;; (defstruct (selection (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :type t :identity t) (format stream (intl:gettext "~A, top ~D, cost ~S") (selection-name s) (length (selection-elements s)) (selection-total-cost s)))))) ;; ;; Some kind of descriptive name. (name (required-argument) :type string) ;; ;; Total cost of all code objects scanned. (total-cost 0d0 :type double-float) ;; ;; List of elements selected. (elements (list (make-selection-elt :cost -1d0)) :type list)) (defconstant count-me-cost-fudge 3d0 _N"Our guess is to how many cycles in each block are really due to profiling.") ;;; SAVE-SELECT-RESULT -- Internal ;;; ;;; First copy all of the counts vectors, then find the debug-functions and ;;; costs. This split avoids considering spurious costs related to parsing ;;; debug-info, etc. ;;; (defun save-select-result (res) (dolist (elt res) (declare (optimize (speed 3) (safety 0))) (let* ((info (selection-elt-info elt)) (counts (dyncount-info-counts info)) (len (length counts)) (new (make-array len :element-type '(unsigned-byte 32)))) (dotimes (i len) (setf (aref new i) (aref counts i))) (setf (selection-elt-counts elt) new))) (dolist (elt res) (let* ((object (selection-elt-code elt)) (debug-info (code-header-ref object vm:code-debug-info-slot)) (map (di::get-debug-info-function-map debug-info)) (costs (dyncount-info-costs (selection-elt-info elt))) (counts (selection-elt-counts elt)) (j 0) (last-j 0)) (declare (simple-vector map)) (dotimes (i (length map)) (declare (fixnum i)) (let ((e (svref map i))) (when (c::compiled-debug-function-p e) (let ((fn (di::make-compiled-debug-function e object)) (sum 0d0)) (declare (double-float sum) (type index j)) (do-debug-function-blocks (blk fn) (unless (debug-block-elsewhere-p blk) (incf sum (* (- (coerce (the (unsigned-byte 31) (aref costs j)) 'double-float) count-me-cost-fudge) (coerce (the (unsigned-byte 31) (aref counts j)) 'double-float))) (incf j))) (push (list fn sum last-j) (selection-elt-functions elt)) (setq last-j j))))))) (undefined-value)) ;;; CLEAR-PROFILE-INFO -- Public ;;; (defun clear-profile-info (&optional (spaces '(:dynamic))) _N"Clear all profiling counts. Call this before running your test." (declare (inline vm::map-allocated-objects) (optimize (speed 3) (safety 0))) (without-gcing (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (code-component-p object) (let ((info (code-header-ref object vm:code-constants-offset))) (when (dyncount-info-p info) (clear-dyncount-info info))))) space))) (values)) ;;; SELECT-PROFILE-RESULT -- Public ;;; (defun select-profile-result (&key (name "unknown") (n 30) (spaces '(:dynamic))) (declare (string name) (list spaces) (type index n)) (let ((res (loop repeat n collect (make-selection-elt :cost -1d0))) (min-cost -1d0) (selection (make-selection :name name))) (declare (type double-float min-cost) (inline vm::map-allocated-objects) (optimize (speed 3) (safety 0))) (without-gcing (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (code-component-p object) (let ((info (code-header-ref object vm:code-constants-offset))) (when (dyncount-info-p info) (let ((costs (dyncount-info-costs info)) (counts (dyncount-info-counts info)) (this-cost 0d0)) (declare (double-float this-cost)) (dotimes (i (length counts)) (incf this-cost (* (coerce (the (unsigned-byte 31) (aref counts i)) 'double-float) (- (coerce (the (unsigned-byte 31) (aref costs i)) 'double-float) count-me-cost-fudge)))) (incf (selection-total-cost selection) this-cost) (when (> this-cost min-cost) (do ((prev res current) (current (cdr res) (cdr current))) ((or (null current) (> (selection-elt-cost (car current)) this-cost)) (setf (cdr prev) (cons (make-selection-elt :cost this-cost :code object :info info) current)))) (let ((old (pop res))) (setq min-cost (selection-elt-cost old))))))))) space))) (loop (unless res (error (intl:gettext "No profilable code objects found."))) (unless (minusp (selection-elt-cost (first res))) (return)) (pop res)) (save-select-result res) (setf (selection-elements selection) res) selection)) (defun function-report (selection &key (top-n 20)) (let ((selected-funs ())) (dolist (elt (selection-elements selection)) (let ((comp-funs ())) (dolist (fun (selection-elt-functions elt)) (let* ((name (debug-function-name (first fun))) (found (assoc name comp-funs :test #'equal))) (if found (incf (cdr found) (second fun)) (push (cons name (second fun)) comp-funs)))) (setq selected-funs (append comp-funs selected-funs)))) (let ((sorted (sort selected-funs #'> :key #'cdr)) (total 0d0)) (declare (double-float total)) (loop for (name . cost) in sorted repeat top-n do (format t "~,2E: ~S~%" cost name) (incf total cost)) (format t (intl:gettext "~,2E: Total~%") total) (format t (intl:gettext "~,2E: Other~%") (- (selection-total-cost selection) total)))) (values)) ;;; FIND-INFO-FOR -- Interface ;;; ;;; Return the DYNCOUNT-INFO for FUNCTION. ;;; (defun find-info-for (function) (declare (type function function)) (let* ((function (%closure-function function)) (component (di::function-code-header function))) (do ((end (get-header-data component)) (i vm:code-constants-offset (1+ i))) ((= end i)) (let ((constant (code-header-ref component i))) (when (dyncount-info-p constant) (return constant)))))) ;; (defun clear-dyncount-info (info) (declare (type dyncount-info info)) (declare (optimize (speed 3) (safety 0))) (let ((counts (dyncount-info-counts info))) (dotimes (i (length counts)) (setf (aref counts i) 0)))) ;; (defun dyncount-total-cost (info) (let ((costs (dyncount-info-costs info)) (counts (dyncount-info-counts info)) (sum 0)) (dotimes (i (length costs)) (incf sum (* (aref costs i) (aref counts i)))) sum)) ;;; SAME-SOURCE-P -- Internal ;;; ;;; Return true if two code locations have the same source form. ;;; (defun same-source-p (x y) (and (= (code-location-form-number x) (code-location-form-number y)) (= (di:code-location-top-level-form-offset x) (di:code-location-top-level-form-offset y)))) ;;; FUNCTION-CYCLES -- External. ;;; (defun function-cycles (name selection &key (top-n 15) (combine t)) (declare (type selection selection)) _N"Print detailed information about the costs associated with a particular function in a SELECTION of dynamic statistics. All functions with names EQUAL to the specified name are reported. If Combine is true, then all blocks with the same source location are combined into a single entry in the report." ;; ;; DFs = list of (selection-elt . (debug-fun cost first-num)) ;; Locs = list of (code-location . (loc-cost max-count)) (collect ((dfs) (locs)) (dolist (sel (selection-elements selection)) (dolist (fun (selection-elt-functions sel)) (when (equal (debug-function-name (first fun)) name) (dfs (cons sel fun))))) (dolist (df (dfs)) (let* ((num (third (cdr df))) (sel (car df)) (counts (selection-elt-counts sel)) (costs (dyncount-info-costs (selection-elt-info sel)))) (declare (type index num)) (do-debug-function-blocks (db (first (cdr df))) (do-debug-block-locations (loc db) (let* ((cnt (coerce (aref counts num) 'double-float)) (cost (* (- (coerce (aref costs num) 'double-float) count-me-cost-fudge) cnt))) (unless (debug-block-elsewhere-p db) (assert (member (code-location-kind loc) '(:block-start :non-local-entry))) (let ((found (and combine (assoc loc (locs) :test #'same-source-p)))) (cond (found (incf (second found) cost) (setf (third found) (max (the double-float (third found)) cnt))) (t (locs (list loc cost cnt))))) (incf num)) (return)))))) (let ((locs (stable-sort (locs) #'>= :key #'second))) (dolist (loc (subseq locs 0 (min (length locs) top-n))) (format t (intl:gettext "~%~,2E cycles, ~[not run, ~;~:; ~:*~D repeats, ~]~ ~S:~% ") (second loc) (truncate (third loc)) (debug-function-name (code-location-debug-function (car loc)))) (debug::print-code-location-source-form (car loc) 0) (fresh-line)))) (values)) #+nil ;;; GET-SPACE-LIST -- Internal. ;;; ;;; (defun get-space-list (spaces clear) (locally (declare (optimize (speed 3) (safety 0)) (inline vm::map-allocated-objects)) (without-gcing (let ((list nil)) (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (kernel:code-component-p object) (let ((info (kernel:code-header-ref object 5)) (j 0) (sum 0) (alist)) (declare (fixnum j)) (when (dyncount-info-p info) (let* ((debug-info (kernel:code-header-ref object 3)) (map (di::get-debug-info-function-map debug-info))) (declare (vector map)) (dotimes (i (length map)) (declare (fixnum i)) (let ((e (svref map i))) (when (c::compiled-debug-function-p e) (let ((fn (di::make-compiled-debug-function e object))) (di:do-debug-function-blocks (blk fn) (unless (di:debug-block-elsewhere-p blk) (incf sum (* (aref (dyncount-info-costs info) j) (aref (dyncount-info-counts info) j))) (incf j))) (let ((a (find (di:debug-function-name fn) alist :key #'car))) (cond (a (incf (third a) sum)) (t (push (list (di:debug-function-name fn) (c::compiled-debug-info-package debug-info) sum) alist))) (setf sum 0))))))) (when clear (clear-dyncount-info info))) (dolist (e alist) (push e list))))) space)) list)))) #+nil ;;; GET-STATS -- External. ;;; ;;; Returns the cycles of all the functions in the spaces. ;;; (defun get-stats (&key (spaces '(:dynamic)) (clear nil) (top-n 10) (cost 0)) (let ((list (stable-sort (sort (get-space-list spaces clear) #'> :key #'third) #'string< :key #'second)) (package-name "") (i 0) (other 0)) (dolist (e list) (unless (string= package-name (second e)) (setf package-name (second e)) (when (> other cost) (format t (intl:gettext " ~10:D: Other~&") other)) (setf i 0) (setf other 0) (when (> (third e) cost) (format t (intl:gettext "Package: ~A~&") package-name))) (cond ((< i top-n) (when (> (third e) cost) (format t (intl:gettext " ~10:D: ~S~&") (third e) (first e)))) (t (incf other (third e)))) (incf i)) (when (> other cost) (format t (intl:gettext " ~10:D: Other~&") other)))) cmucl-21a/src/code/debug-info.lisp000066400000000000000000000462021260377556400171760ustar00rootroot00000000000000;;; -*- Log: code.log; Package: C -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/debug-info.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains structures used for recording debugger information. ;;; (in-package "C") (intl:textdomain "cmucl") (export '(make-sc-offset sc-offset-scn sc-offset-offset read-var-integer write-var-integer read-var-string write-var-string read-packed-bit-vector write-packed-bit-vector)) ;;;; SC-Offsets: ;;; ;;; We represent the place where some value is stored with a SC-OFFSET, ;;; which is the SC number and offset encoded as an integer. (defconstant sc-offset-scn-byte (byte 5 0)) (defconstant sc-offset-offset-byte (byte 22 5)) (deftype sc-offset () '(unsigned-byte 27)) (defmacro make-sc-offset (scn offset) `(dpb ,scn sc-offset-scn-byte (dpb ,offset sc-offset-offset-byte 0))) (defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco)) (defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco)) ;;;; Variable length integers: ;;; ;;; The debug info representation makes extensive use of integers encoded in ;;; a byte vector using a variable number of bytes: ;;; 0..253 => the integer ;;; 254 => read next two bytes for integer ;;; 255 => read next four bytes for integer ;;; READ-VAR-INTEGER -- Interface ;;; ;;; Given a byte vector Vec and an index variable Index, read a variable ;;; length integer and advance index. ;;; (defmacro read-var-integer (vec index) (once-only ((val `(aref ,vec ,index))) `(cond ((<= ,val 253) (incf ,index) ,val) ((= ,val 254) (prog1 (logior (aref ,vec (+ ,index 1)) (ash (aref ,vec (+ ,index 2)) 8)) (incf ,index 3))) (t (prog1 (logior (aref ,vec (+ ,index 1)) (ash (aref ,vec (+ ,index 2)) 8) (ash (aref ,vec (+ ,index 3)) 16) (ash (aref ,vec (+ ,index 4)) 24)) (incf ,index 5)))))) ;;; WRITE-VAR-INTEGER -- Interface ;;; ;;; Takes an adjustable vector Vec with a fill pointer and pushes the ;;; variable length representation of Int on the end. ;;; (defun write-var-integer (int vec) (declare (type (unsigned-byte 32) int)) (cond ((<= int 253) (vector-push-extend int vec)) (t (let ((32-p (> int #xFFFF))) (vector-push-extend (if 32-p 255 254) vec) (vector-push-extend (ldb (byte 8 0) int) vec) (vector-push-extend (ldb (byte 8 8) int) vec) (when 32-p (vector-push-extend (ldb (byte 8 16) int) vec) (vector-push-extend (ldb (byte 8 24) int) vec))))) (undefined-value)) ;;;; Packed strings: ;;; ;;; A packed string is a variable length integer length followed by the ;;; character codes. ;;; READ-VAR-STRING -- Interface ;;; ;;; Read a packed string from Vec starting at Index, leaving advancing ;;; Index. ;;; #-unicode (defmacro read-var-string (vec index) (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len))) `(progn (%primitive byte-blt ,vec ,index ,res 0 ,len) (incf ,index ,len) ,res)))) #+unicode (defmacro read-var-string (vec index) (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len)) (k 0)) `(progn (dotimes (,k ,len) (let ((lo (aref ,vec (+ ,index (* 2 ,k)))) (hi (aref ,vec (+ ,index (+ (* 2 ,k) 1))))) (setf (aref ,res ,k) (code-char (+ lo (ash hi 8)))))) (incf ,index (* 2 ,len)) ,res)))) ;;; WRITE-VAR-STRING -- Interface ;;; ;;; Write String into Vec (adjustable, fill-pointer) represented as the ;;; length (in a var-length integer) followed by the codes of the characters. ;;; (defun write-var-string (string vec) (declare (simple-string string)) (let ((len (length string))) (write-var-integer len vec) (dotimes (i len) (vector-push-extend (ldb (byte 8 0) (char-code (schar string i))) vec) #+unicode (vector-push-extend (ldb (byte 8 8) (char-code (schar string i))) vec))) (undefined-value)) ;;;; Packed bit vectors: ;;; ;;; READ-PACKED-BIT-VECTOR -- Interface ;;; ;;; Read the specified number of Bytes out of Vec at Index and convert them ;;; to a bit-vector. Index is incremented. ;;; (defmacro read-packed-bit-vector (bytes vec index) (once-only ((n-bytes bytes)) (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit))) `(progn (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes) (incf ,index ,n-bytes) ,n-res)))) ;;; WRITE-PACKED-BIT-VECTOR -- Interface ;;; ;;; Write Bits out to Vec. Bits must be an eight-bit multiple. ;;; (defun write-packed-bit-vector (bits vec) (declare (type simple-bit-vector bits)) (let ((len (length bits)) (start (fill-pointer vec))) (cond ((eq (backend-byte-order *backend*) (backend-byte-order *native-backend*)) (let ((bytes (ash len -3))) (dotimes (i bytes) (vector-push-extend 0 vec)) (lisp::with-array-data ((data vec) (ig1) (ig2)) (declare (ignore ig1 ig2)) (%primitive byte-blt bits 0 data start (+ start bytes))))) (t (macrolet ((frob (initial step done) `(let ((shift ,initial) (byte 0)) (dotimes (i len) (let ((int (aref bits i))) (setq byte (logior byte (ash int shift))) (,step shift)) (when ,done (vector-push-extend byte vec) (setq shift ,initial byte 0))) (unless (= shift ,initial) (vector-push-extend byte vec))))) (ecase (backend-byte-order *backend*) (:little-endian (frob 0 incf (= shift 8))) (:big-endian (frob 7 decf (minusp shift)))))))) (undefined-value)) ;;;; Compiled debug variables: ;;; ;;; Compiled debug variables are in a packed binary representation in the ;;; DEBUG-FUNCTION-VARIABLES: ;;; single byte of boolean flags: ;;; uninterned name ;;; packaged name ;;; environment-live ;;; has distinct save location ;;; has ID (name not unique in this fun) ;;; minimal debug-info argument (name generated as ARG-0, ...) ;;; deleted: placeholder for unused minimal argument ;;; [name length in bytes (as var-length integer), if not minimal] ;;; [...name bytes..., if not minimal] ;;; [if packaged, var-length integer that is package name length] ;;; ...package name bytes...] ;;; [If has ID, ID as var-length integer] ;;; SC-Offset of primary location (as var-length integer) ;;; [If has save SC, SC-Offset of save location (as var-length integer)] (defconstant compiled-debug-variable-uninterned #b00000001) (defconstant compiled-debug-variable-packaged #b00000010) (defconstant compiled-debug-variable-environment-live #b00000100) (defconstant compiled-debug-variable-save-loc-p #b00001000) (defconstant compiled-debug-variable-id-p #b00010000) (defconstant compiled-debug-variable-minimal-p #b00100000) (defconstant compiled-debug-variable-deleted-p #b01000000) ;;;; Compiled debug blocks: ;;; ;;; Compiled debug blocks are in a packed binary representation in the ;;; DEBUG-FUNCTION-BLOCKS: ;;; number of successors + bit flags (single byte) ;;; elsewhere-p ;;; ...ordinal number of each successor in the function's blocks vector... ;;; number of locations in this block ;;; kind of first location (single byte) ;;; delta from previous PC (or from 0 if first location in function.) ;;; [offset of first top-level form, if no function TLF-NUMBER] ;;; form number of first source form ;;; first live mask (length in bytes determined by number of VARIABLES) ;;; ...more ;;; tuples... (defconstant compiled-debug-block-nsucc-byte (byte 2 0)) (defconstant compiled-debug-block-elsewhere-p #b00000100) (defconstant compiled-code-location-kind-byte (byte 3 0)) (defconstant compiled-code-location-kinds '#(:unknown-return :known-return :internal-error :non-local-exit :block-start :call-site :single-value-return :non-local-entry)) ;;;; Debug function: (defstruct debug-function) (defstruct (compiled-debug-function (:include debug-function) (:pure t)) ;; ;; The name of this function. If from a DEFUN, etc., then this is the ;; function name, otherwise it is a descriptive string. (name (required-argument) :type (or simple-string cons symbol)) ;; ;; The kind of function (same as FUNCTIONAL-KIND): (kind nil :type (member nil :optional :external :top-level :cleanup)) ;; ;; A vector of the packed binary representation of variable locations in this ;; function. These are in alphabetical order by name. This ordering is used ;; in lifetime info to refer to variables: the first entry is 0, the second ;; entry is 1, etc. Variable numbers are *not* the byte index at which the ;; representation of the location starts. This slot may be NIL to save ;; space. (variables nil :type (or (simple-array (unsigned-byte 8) (*)) null)) ;; ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKS ;; in this function, in the order that the blocks were emitted. The first ;; block is the start of the function. This slot may be NIL to save space. (blocks nil :type (or (simple-array (unsigned-byte 8) (*)) null)) ;; ;; If all code locations in this function are in the same top-level form, ;; then this is the number of that form, otherwise NIL. If NIL, then each ;; code location represented in the BLOCKS specifies the TLF number. (tlf-number nil :type (or index null)) ;; ;; A vector describing the variables that the argument values are stored in ;; within this function. The locations are represented by the ordinal number ;; of the entry in the VARIABLES. The locations are in the order that the ;; arguments are actually passed in, but special marker symbols can be ;; interspersed to indicate the orignal call syntax: ;; ;; DELETED ;; There was an argument to the function in this position, but it was ;; deleted due to lack of references. The value cannot be recovered. ;; ;; SUPPLIED-P ;; The following location is the supplied-p value for the preceding ;; keyword or optional. ;; ;; OPTIONAL-ARGS ;; Indicates that following unqualified args are optionals, not required. ;; ;; REST-ARG ;; The following location holds the list of rest args. ;; ;; MORE-ARG ;; The following two locations are the more arg context and count. ;; ;; ;; The following location is the value of the keyword argument with the ;; specified name. ;; ;; This may be NIL to save space. If no symbols are present, then this will ;; be represented with an I-vector with sufficiently large element type. If ;; this is :MINIMAL, then this means that the VARIABLES are all required ;; arguments, and are in the order they appear in the VARIABLES vector. In ;; other words, :MINIMAL stands in for a vector where every element holds its ;; index. (arguments nil :type (or (simple-array * (*)) (member :minimal nil))) ;; ;; There are three alternatives for this slot: ;; ;; A vector ;; A vector of SC-OFFSETS describing the return locations. The ;; vector element type is chosen to hold the largest element. ;; ;; :Standard ;; The function returns using the standard unknown-values convention. ;; ;; :Fixed ;; The function returns using the a fixed-values convention, but we ;; elected not to store a vector to save space. (returns :fixed :type (or (simple-array * (*)) (member :standard :fixed))) ;; ;; SC-Offsets describing where the return PC and return FP are kept. (return-pc (required-argument) :type sc-offset) (old-fp (required-argument) :type sc-offset) ;; ;; SC-Offset for the number stack FP in this function, or NIL if no NFP ;; allocated. (nfp nil :type (or sc-offset null)) ;; ;; The earliest PC in this function at which the environment is properly ;; initialized (arguments moved from passing locations, etc.) (start-pc (required-argument) :type index) ;; ;; The start of elsewhere code for this function (if any.) (elsewhere-pc (required-argument) :type index)) ;;;; Minimal debug function: ;;; The minimal debug info format compactly represents debug-info for some ;;; cases where the other debug info (variables, blocks) is small enough ;;; that the per-function overhead becomes relatively large. The minimal ;;; debug-info format can represent any function at level 0, and any fixed-arg ;;; function at level 1. ;;; ;;; In the minimal format, the debug functions and function map are packed into ;;; a single byte-vector which is placed in the ;;; COMPILED-DEBUG-INFO-FUNCTION-MAP. Because of this, all functions in a ;;; component must be representable in minimal format for any function to ;;; actually be dumped in minimal format. The vector is a sequence of records ;;; in this format: ;;; name representation + kind + return convention (single byte) ;;; bit flags (single byte) ;;; setf, nfp, variables ;;; [package name length (as var-length int), if name is packaged] ;;; [...package name bytes, if name is packaged] ;;; [name length (as var-length int), if there is a name] ;;; [...name bytes, if there is a name] ;;; [variables length (as var-length int), if variables flag] ;;; [...bytes holding variable descriptions] ;;; If variables are dumped (level 1), then the variables are all ;;; arguments (in order) with the minimal-arg bit set. ;;; [If returns is specified, then the number of return values] ;;; [...sequence of var-length ints holding sc-offsets of the return ;;; value locations, if fixed return values are specified.] ;;; return-pc location sc-offset (as var-length int) ;;; old-fp location sc-offset (as var-length int) ;;; [nfp location sc-offset (as var-length int), if nfp flag] ;;; code-start-pc (as a var-length int) ;;; This field implicitly encodes start of this function's code in the ;;; function map, as a delta from the previous function's code start. ;;; If the first function in the component, then this is the delta from ;;; 0 (i.e. the absolute offset). ;;; start-pc (as a var-length int) ;;; This encodes the environment start PC as an offset from the ;;; code-start PC. ;;; elsewhere-pc ;;; This encodes the elsewhere code start for this function, as a delta ;;; from the previous function's elsewhere code start. (i.e. the ;;; encoding is the same as for code-start-pc). ;;; ;;; #| ### For functions with XEPs, name could be represented more simply and compactly as some sort of info about how to find the function-entry that this is a function for. Actually, you really hardly need any info. You can just chain through the functions in the component until you find the right one. Well, I guess you need to at least know which function is an XEP for the real function (which would be useful info anyway). |# ;;; Following are definitions of bit-fields in the first byte of the minimal ;;; debug function: ;;; (defconstant minimal-debug-function-name-symbol 0) (defconstant minimal-debug-function-name-packaged 1) (defconstant minimal-debug-function-name-uninterned 2) (defconstant minimal-debug-function-name-component 3) (defconstant minimal-debug-function-name-style-byte (byte 2 0)) (defconstant minimal-debug-function-kind-byte (byte 3 2)) (defconstant minimal-debug-function-kinds '#(nil :optional :external :top-level :cleanup)) (defconstant minimal-debug-function-returns-standard 0) (defconstant minimal-debug-function-returns-specified 1) (defconstant minimal-debug-function-returns-fixed 2) (defconstant minimal-debug-function-returns-byte (byte 2 5)) ;;; The following are bit-flags in the second byte of the minimal debug ;;; function: ;;; If true, wrap (SETF ...) around the name. (defconstant minimal-debug-function-setf-bit (ash 1 0)) ;;; If true, there is a NFP. (defconstant minimal-debug-function-nfp-bit (ash 1 1)) ;;; If true, variables (hence arguments) have been dumped. (defconstant minimal-debug-function-variables-bit (ash 1 2)) ;;;; Debug source: (defstruct (debug-source (:pure t)) ;; ;; This slot indicates where the definition came from: ;; :File - from a file (Compile-File) ;; :Lisp - from Lisp (Compile) ;; :Stream - from a non-file stream (Compile-From-Stream) (from (required-argument) :type (member :file :stream :lisp)) ;; ;; If :File, the file name, if :Lisp or :Stream, then a vector of the ;; top-level forms. When from COMPILE, form 0 is #'(LAMBDA ...). (name nil) ;; ;; File comment for this file, if any. (comment nil :type (or simple-string null)) ;; ;; The universal time that the source was written, or NIL if unavailable. (created nil :type (or unsigned-byte null)) ;; ;; The universal time that the source was compiled. (compiled (required-argument) :type unsigned-byte) ;; ;; The source path root number of the first form read from this source (i.e. ;; the total number of forms converted previously in this compilation). (source-root 0 :type index) ;; ;; The file-positions of each truly top-level form read from this file (if ;; applicable). The vector element type will be chosen to hold the largest ;; element. May be null to save space. (start-positions nil :type (or (simple-array * (*)) null)) ;; ;; If from :LISP, this is the function whose source is form 0. ;; If from :STREAM, this is whatever was the :SOURCE-INFO argument to ;; COMPILE-FROM-STREAM. ;; If from :FILE, this is the external format used to read from the ;; file while compiling (info nil)) ;;;; The DEBUG-INFO structure: (defstruct debug-info ;; ;; Some string describing something about the code in this component. (name (required-argument) :type simple-string) ;; ;; A list of DEBUG-SOURCE structures describing where the code for this ;; component came from, in the order that they were read. ;; ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it ;; *** can backpatch the source info when compilation is complete. (source nil :type list)) (defstruct (compiled-debug-info (:include debug-info) (:pure t)) ;; ;; The name of the package that DEBUG-FUNCTION-VARIABLES were dumped relative ;; to. Locations that aren't packaged are in this package. (package (required-argument) :type simple-string) ;; ;; Either a simple-vector or a byte-vector holding the debug functions for ;; this component. This is used to map PCs to functions, so that we can ;; figure out what function we were running in. If a byte-vector, then it is ;; a sequence of minimal debug functions in a packed binary representation. ;; ;; If a simple-vector, then it alternates Debug-Function structures and ;; fixnum PCs. The function is valid between the PC before it (inclusive) ;; and the PC after it (exclusive). The PCs are in sorted order, so we can ;; binary-search. We omit the first and last PC, since their values are 0 ;; and the length of the code vector. Null only temporarily. (function-map nil :type (or simple-vector (simple-array (unsigned-byte 8) (*)) null))) cmucl-21a/src/code/debug-int.lisp000066400000000000000000005700011260377556400170340ustar00rootroot00000000000000;;; -*- Mode: Lisp; Log: code.log; Package: DI -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/debug-int.lisp,v 1.142 2010-07-14 23:08:59 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the implementation of the programmer's interface ;;; to writing debugging tools. ;;; ;;; Written by Bill Chiles and Rob Maclachlan. ;;; ;;; X86 support by Douglas Crosher 1996,1997,1998. (in-package "DEBUG-INTERNALS") (intl:textdomain "cmucl") ;;; The compiler's debug-source structure is almost exactly what we want, so ;;; just get these symbols and export them. ;;; (import '(c::debug-source-from c::debug-source-name c::debug-source-created c::debug-source-compiled c::debug-source-start-positions c::make-debug-source c::debug-source c::debug-source-p)) (export '(debug-variable-name debug-variable-package debug-variable-symbol debug-variable-id debug-variable-value debug-variable-validity debug-variable-valid-value debug-variable debug-variable-p top-frame frame-down frame-up flush-frames-above frame-debug-function frame-code-location eval-in-frame return-from-frame frame-catches frame-number frame frame-p find-debug-tag-for-frame do-debug-function-blocks debug-function-lambda-list debug-variable-info-available do-debug-function-variables debug-function-symbol-variables ambiguous-debug-variables preprocess-for-eval function-debug-function debug-function-function debug-function-kind debug-function-name debug-function debug-function-p debug-function-start-location do-debug-block-locations debug-block-successors debug-block debug-block-p debug-block-elsewhere-p make-breakpoint activate-breakpoint deactivate-breakpoint breakpoint-active-p breakpoint-hook-function breakpoint-info breakpoint-kind breakpoint-what breakpoint breakpoint-p delete-breakpoint function-end-cookie-valid-p code-location-debug-function code-location-debug-block code-location-top-level-form-offset code-location-form-number code-location-debug-source code-location-kind code-location code-location-p code-location-unknown-p code-location= debug-source-from debug-source-name debug-source-created debug-source-compiled debug-source-root-number debug-source-start-positions form-number-translations source-path-context debug-source debug-source-p debug-condition no-debug-info no-debug-function-returns no-debug-blocks lambda-list-unavailable debug-error unhandled-condition invalid-control-stack-pointer unknown-code-location unknown-debug-variable invalid-value ambiguous-variable-name frame-function-mismatch set-breakpoint-for-editor set-location-breakpoint-for-editor delete-breakpoint-for-editor *debugging-interpreter*)) ;;;; Conditions. ;;; The interface to building debugging tools signals conditions that prevent ;;; it from adhering to its contract. These are serious-conditions because the ;;; program using the interface must handle them before it can correctly ;;; continue execution. These debugging conditions are not errors since it is ;;; no fault of the programmers that the conditions occur. The interface does ;;; not provide for programs to detect these situations other than calling a ;;; routine that detects them and signals a condition. For example, ;;; programmers call A which may fail to return successfully due to a lack of ;;; debug information, and there is no B that they could have called to realize ;;; A would fail. It is not an error to have called A, but it is an error for ;;; the program to then ignore the signal generated by A since it cannot ;;; continue without A's correctly returning a value or performing some ;;; operation. ;;; ;;; Use DEBUG-SIGNAL to signal these conditions. ;;; (define-condition debug-condition (serious-condition) () (:documentation _N"All debug-conditions inherit from this type. These are serious conditions that must be handled, but they are not programmer errors.")) (define-condition no-debug-info (debug-condition) () (:documentation _N"There is absolutely no debugging information available.") (:report (lambda (condition stream) (declare (ignore condition)) (fresh-line stream) (write-line (intl:gettext "No debugging information available.") stream)))) (define-condition no-debug-function-returns (debug-condition) ((debug-function :reader no-debug-function-returns-debug-function :initarg :debug-function)) (:documentation (intl:gettext "The system could not return values from a frame with debug-function since it lacked information about returning values.")) (:report (lambda (condition stream) (let ((fun (debug-function-function (no-debug-function-returns-debug-function condition)))) (format stream (intl:gettext "~&Cannot return values from ~:[frame~;~:*~S~] since ~ the debug information lacks details about returning ~ values here.") fun))))) (define-condition no-debug-blocks (debug-condition) ((debug-function :reader no-debug-blocks-debug-function :initarg :debug-function)) (:documentation _N"The debug-function has no debug-block information.") (:report (lambda (condition stream) (format stream (intl:gettext "~&~S has no debug-block information.") (no-debug-blocks-debug-function condition))))) (define-condition no-debug-variables (debug-condition) ((debug-function :reader no-debug-variables-debug-function :initarg :debug-function)) (:documentation _N"The debug-function has no debug-variable information.") (:report (lambda (condition stream) (format stream (intl:gettext "~&~S has no debug-variable information.") (no-debug-variables-debug-function condition))))) (define-condition lambda-list-unavailable (debug-condition) ((debug-function :reader lambda-list-unavailable-debug-function :initarg :debug-function)) (:documentation _N"The debug-function has no lambda-list since argument debug-variables are unavailable.") (:report (lambda (condition stream) (format stream (intl:gettext "~&~S has no lambda-list information available.") (lambda-list-unavailable-debug-function condition))))) (define-condition invalid-value (debug-condition) ((debug-variable :reader invalid-value-debug-variable :initarg :debug-variable) (frame :reader invalid-value-frame :initarg :frame)) (:report (lambda (condition stream) (format stream (intl:gettext "~&~S has :invalid or :unknown value in ~S.") (invalid-value-debug-variable condition) (invalid-value-frame condition))))) (define-condition ambiguous-variable-name (debug-condition) ((name :reader ambiguous-variable-name-name :initarg :name) (frame :reader ambiguous-variable-name-frame :initarg :frame)) (:report (lambda (condition stream) (format stream (intl:gettext "~&~S names more than one valid variable in ~S.") (ambiguous-variable-name-name condition) (ambiguous-variable-name-frame condition))))) ;;;; Errors and DEBUG-SIGNAL. ;;; The debug-internals code tries to signal all programmer errors as subtypes ;;; of debug-error. There are calls to ERROR signalling simple-errors, but ;;; these dummy checks in the code shouldn't come up. ;;; ;;; While under development, this code also signals errors in code branches ;;; that remain unimplemented. ;;; (define-condition debug-error (error) () (:documentation _N"All programmer errors from using the interface for building debugging tools inherit from this type.")) (define-condition unhandled-condition (debug-error) ((condition :reader unhandled-condition-condition :initarg :condition)) (:report (lambda (condition stream) (format stream (intl:gettext "~&Unhandled debug-condition:~%~A") (unhandled-condition-condition condition))))) (define-condition unknown-code-location (debug-error) ((code-location :reader unknown-code-location-code-location :initarg :code-location)) (:report (lambda (condition stream) (format stream (intl:gettext "~&Invalid use of an unknown code-location -- ~S.") (unknown-code-location-code-location condition))))) (define-condition unknown-debug-variable (debug-error) ((debug-variable :reader unknown-debug-variable-debug-variable :initarg :debug-variable) (debug-function :reader unknown-debug-variable-debug-function :initarg :debug-function)) (:report (lambda (condition stream) (format stream (intl:gettext "~&~S not in ~S.") (unknown-debug-variable-debug-variable condition) (unknown-debug-variable-debug-function condition))))) (define-condition invalid-control-stack-pointer (debug-error) () (:report (lambda (condition stream) (declare (ignore condition)) (fresh-line stream) (write-string (intl:gettext "Invalid control stack pointer.") stream)))) (define-condition frame-function-mismatch (debug-error) ((code-location :reader frame-function-mismatch-code-location :initarg :code-location) (frame :reader frame-function-mismatch-frame :initarg :frame) (form :reader frame-function-mismatch-form :initarg :form)) (:report (lambda (condition stream) (format stream (intl:gettext "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S") (frame-function-mismatch-code-location condition) (frame-function-mismatch-frame condition) (frame-function-mismatch-form condition))))) ;;; DEBUG-SIGNAL -- Internal. ;;; ;;; This signals debug-conditions. If they go unhandled, then signal an ;;; unhandled-condition error. ;;; ;;; ??? Get SIGNAL in the right package! ;;; (defmacro debug-signal (datum &rest arguments) `(let ((condition (make-condition ,datum ,@arguments))) (signal condition) (error 'unhandled-condition :condition condition))) ;;;; Structures. ;;; Most of these structures model information stored in internal data ;;; structures created by the compiler. Whenever comments preface an object or ;;; type with "compiler", they refer to the internal compiler thing, not to the ;;; object or type with the same name in the "DI" package. ;;; ;;; ;;; Debug-variables ;;; ;;; These exist for caching data stored in packed binary form in compiler ;;; debug-functions. Debug-functions store these. ;;; (defstruct (debug-variable (:print-function print-debug-variable) (:constructor nil)) ;; ;; String name of variable. (name nil :type simple-string) ;; ;; String name of package. Nil when variable's name is uninterned. (package nil :type (or null simple-string)) ;; ;; Unique integer identification relative to other variables with the same ;; name and package. (id 0 :type c::index) ;; ;; Whether the variable always has a valid value. (alive-p nil :type boolean)) (defun print-debug-variable (obj str n) (declare (ignore n)) (format str "#" (debug-variable-package obj) (debug-variable-name obj) (debug-variable-id obj))) (setf (documentation 'debug-variable-name 'function) _N"Returns the name of the debug-variable. The name is the name of the symbol used as an identifier when writing the code.") (setf (documentation 'debug-variable-package 'function) _N"Returns the package name of the debug-variable. This is the package name of the symbol used as an identifier when writing the code.") (setf (documentation 'debug-variable-id 'function) _N"Returns the integer that makes debug-variable's name and package name unique with respect to other debug-variable's in the same function.") (defstruct (compiled-debug-variable (:include debug-variable) (:constructor make-compiled-debug-variable (name package id alive-p sc-offset save-sc-offset))) ;; ;; Storage class and offset. (unexported). (sc-offset nil :type c::sc-offset) ;; ;; Storage class and offset when saved somewhere. (save-sc-offset nil :type (or c::sc-offset null))) (defstruct (interpreted-debug-variable (:include debug-variable (alive-p t)) (:constructor make-interpreted-debug-variable (name package ir1-var))) ;; ;; This is the IR1 structure that holds information about interpreted vars. (ir1-var nil :type c::lambda-var)) ;;; ;;; Frames ;;; ;;; These represent call-frames on the stack. ;;; (defstruct (frame (:constructor nil)) ;; ;; Next frame up. Null when top frame. (up nil :type (or frame null)) ;; ;; Previous frame down. Nil when the bottom frame. Before computing the ;; next frame down, this slot holds the frame pointer to the control stack ;; for the given frame. This lets us get the next frame down and the ;; return-pc for that frame. (%down :unparsed :type (or frame (member nil :unparsed))) ;; ;; Debug-function for function whose call this frame represents. (debug-function nil :type debug-function) ;; ;; Code-location to continue upon return to frame. (code-location nil :type code-location) ;; ;; A-list of catch-tags to code-locations. (%catches :unparsed :type (or list (member :unparsed))) ;; ;; Pointer to frame on control stack. (unexported) ;; When is an interpreted-frame, this is an index into the interpreter's ;; stack. pointer ;; ;; This is the frame's number for prompt printing. Top is zero. (number 0 :type index)) (setf (documentation 'frame-up 'function) _N"Returns the frame immediately above frame on the stack. When frame is the top of the stack, this returns nil.") (setf (documentation 'frame-debug-function 'function) _N"Returns the debug-function for the function whose call frame represents.") (setf (documentation 'frame-code-location 'function) _N"Returns the code-location where the frame's debug-function will continue running when program execution returns to this frame. If someone interrupted this frame, the result could be an unknown code-location.") (defstruct (compiled-frame (:include frame) (:print-function print-compiled-frame) (:constructor make-compiled-frame (pointer up debug-function code-location number #+gengc saved-state-chain &optional escaped))) ;; ;; Indicates whether someone interrupted frame. (unexported). ;; If escaped, this is a pointer to the state that was saved when we were ;; interrupted. On the non-gengc system, this is a sigcontext pointer. ;; On the gengc system, this is a state pointer from saved-state-chain. escaped ;; ;; List of saps to saved states. Each time we unwind past an exception, ;; we pop the next entry off this list. When we get to the end of the ;; list, there is nothing else on the stack. #+gengc (saved-state-chain nil :type list)) (defun print-compiled-frame (obj str n) (declare (ignore n)) (format str (intl:gettext "#") (debug-function-name (frame-debug-function obj)) (compiled-frame-escaped obj))) (defstruct (interpreted-frame (:include frame) (:print-function print-interpreted-frame) (:constructor make-interpreted-frame (pointer up debug-function code-location number real-frame closure))) ;; ;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP. (real-frame nil :type compiled-frame) ;; ;; This is the closed over data used by the interpreter. (closure nil :type simple-vector)) (defun print-interpreted-frame (obj str n) (declare (ignore n)) (format str "#" (debug-function-name (frame-debug-function obj)))) ;;; ;;; Debug-functions ;;; ;;; These exist for caching data stored in packed binary form in compiler ;;; debug-functions. *compiled-debug-functions* maps a c::debug-function to a ;;; debug-function. There should only be one debug-function in existence for ;;; any function; that is, all code-locations and other objects that reference ;;; debug-functions point to unique objects. This is due to the overhead in ;;; cached information. ;;; (defstruct (debug-function (:print-function print-debug-function)) ;; ;; Some representation of the function arguments. See ;; DEBUG-FUNCTION-LAMBDA-LIST. ;; NOTE: must parse vars before parsing arg list stuff. (%lambda-list :unparsed) ;; ;; Cached debug-variable information. (unexported). ;; These are sorted by their name. (debug-vars :unparsed :type (or simple-vector null (member :unparsed))) ;; ;; Cached debug-block information. This is nil when we have tried to parse ;; the packed binary info, but none is available. (blocks :unparsed :type (or simple-vector null (member :unparsed))) ;; ;; The actual function if available. (%function :unparsed :type (or null function (member :unparsed)))) (defun print-debug-function (obj str n) (declare (ignore n)) (format str (intl:gettext "#<~A-Debug-Function ~S>") (etypecase obj (compiled-debug-function "Compiled") (interpreted-debug-function "Interpreted") (bogus-debug-function "Bogus")) (debug-function-name obj))) (defstruct (compiled-debug-function (:include debug-function) (:constructor %make-compiled-debug-function (compiler-debug-fun component))) ;; ;; Compiler's dumped debug-function information. (unexported). (compiler-debug-fun nil :type c::compiled-debug-function) ;; ;; Code object. (unexported). component ;; ;; The :function-start breakpoint (if any) used to facilitate function ;; end breakpoints. (end-starter nil :type (or null breakpoint))) ;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we ;;; can get at cached stuff and not duplicate compiled-debug-function ;;; structures. ;;; (defvar *compiled-debug-functions* (make-hash-table :test #'eq)) ;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal. ;;; ;;; Makes a compiled-debug-function for a c::compiler-debug-function and its ;;; component. This maps the latter to the former in ;;; *compiled-debug-functions*. If there already is a compiled-debug-function, ;;; then this returns it from *compiled-debug-functions*. ;;; (defun make-compiled-debug-function (compiler-debug-fun component) (or (gethash compiler-debug-fun *compiled-debug-functions*) (setf (gethash compiler-debug-fun *compiled-debug-functions*) (%make-compiled-debug-function compiler-debug-fun component)))) (defstruct (interpreted-debug-function (:include debug-function) (:constructor %make-interpreted-debug-function (ir1-lambda))) ;; ;; This is the ir1 lambda this debug-function represents. (ir1-lambda nil :type c::clambda)) (defstruct (bogus-debug-function (:include debug-function) (:constructor make-bogus-debug-function (%name &aux (%lambda-list nil) (debug-vars nil) (blocks nil) (%function nil)))) %name) (defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq)) (defun make-interpreted-debug-function (ir1-lambda) (let ((home-lambda (c::lambda-home ir1-lambda))) (or (gethash home-lambda *ir1-lambda-debug-function*) (setf (gethash home-lambda *ir1-lambda-debug-function*) (%make-interpreted-debug-function home-lambda))))) ;;; ;;; Debug-blocks. ;;; ;;; These exist for caching data stored in packed binary form in compiler ;;; debug-blocks. ;;; (defstruct (debug-block (:print-function print-debug-block)) ;; ;; Code-locations where execution continues after this block. (successors nil :type list) ;; ;; This indicates whether the block is a special glob of code shared by ;; various functions and tucked away elsewhere in a component. This kind of ;; block has no start code-location. In an interpreted-debug-block, this is ;; always nil. This slot is in all debug-blocks since it is an exported ;; interface. (elsewhere-p nil :type boolean)) (defun print-debug-block (obj str n) (declare (ignore n)) (format str "#<~A-Debug-Block ~S>" (etypecase obj (compiled-debug-block "Compiled") (interpreted-debug-block "Interpreted")) (debug-block-function-name obj))) (setf (documentation 'debug-block-successors 'function) _N"Returns the list of possible code-locations where execution may continue when the basic-block represented by debug-block completes its execution.") (setf (documentation 'debug-block-elsewhere-p 'function) _N"Returns whether debug-block represents elsewhere code.") (defstruct (compiled-debug-block (:include debug-block) (:constructor make-compiled-debug-block (code-locations successors elsewhere-p))) ;; ;; Code-location information for the block. (code-locations nil :type simple-vector)) (defstruct (interpreted-debug-block (:include debug-block (elsewhere-p nil)) (:constructor %make-interpreted-debug-block (ir1-block))) ;; ;; This is the IR1 block this debug-block represents. (ir1-block nil :type c::cblock) ;; ;; Code-location information for the block. (locations :unparsed :type (or (member :unparsed) simple-vector))) (defvar *ir1-block-debug-block* (make-hash-table :test #'eq)) ;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal. ;;; ;;; This makes a debug-block for the interpreter's ir1-block. If we have it in ;;; the cache, return it. If we need to make it, then first make debug-blocks ;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the ;;; successors of ir1-block have debug-blocks. We need this to fill in the ;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks. ;;; After making all the possible debug-blocks we'll need to reference, go back ;;; over the list of new debug-blocks and fill in their successor slots with ;;; lists of debug-blocks. Then look up our argument ir1-block to find its ;;; debug-block since we know we have it now. ;;; (defun make-interpreted-debug-block (ir1-block) (check-type ir1-block c::cblock) (let ((res (gethash ir1-block *ir1-block-debug-block*))) (or res (let ((lambda (c::block-home-lambda ir1-block))) (c::do-blocks (block (c::block-component ir1-block)) (when (eq lambda (c::block-home-lambda block)) (push (setf (gethash block *ir1-block-debug-block*) (%make-interpreted-debug-block block)) res))) (dolist (block res) (let* ((successors nil) (cblock (interpreted-debug-block-ir1-block block)) (succ (c::block-succ cblock)) (valid-succ (if (and succ (eq (car succ) (c::component-tail (c::block-component cblock)))) () succ))) (dolist (sblock valid-succ) (let ((dblock (gethash sblock *ir1-block-debug-block*))) (when dblock (push dblock successors)))) (setf (debug-block-successors block) (nreverse successors)))) (gethash ir1-block *ir1-block-debug-block*))))) ;;; ;;; Breakpoints. ;;; ;;; This is an internal structure that manages information about a breakpoint ;;; locations. See *component-breakpoint-offsets*. ;;; (defstruct (breakpoint-data (:print-function print-breakpoint-data) (:constructor make-breakpoint-data (component offset))) ;; ;; This is the component in which the breakpoint lies. component ;; ;; This is the byte offset into the component. (offset nil :type c::index) ;; ;; The original instruction replaced by the breakpoint. (instruction nil :type (or null (unsigned-byte 32))) ;; ;; A list of user breakpoints at this location. (breakpoints nil :type list)) ;;; (defun print-breakpoint-data (obj str n) (declare (ignore n)) (format str "#" (debug-function-name (debug-function-from-pc (breakpoint-data-component obj) (breakpoint-data-offset obj))) (breakpoint-data-offset obj))) (defstruct (breakpoint (:print-function print-breakpoint) (:constructor %make-breakpoint (hook-function what kind %info))) ;; ;; This is the function invoked when execution encounters the breakpoint. It ;; takes a frame, the breakpoint, and optionally a list of values. Values ;; are supplied for :function-end breakpoints as values to return for the ;; function containing the breakpoint. :function-end breakpoint ;; hook-functions also take a cookie argument. See cookie-fun slot. (hook-function nil :type function) ;; ;; Code-location or debug-function. (what nil :type (or code-location debug-function)) ;; ;; :code-location, :function-start, or :function-end for that kind of ;; breakpoint. :unknown-return-partner if this is the partner of a ;; :code-location breakpoint at an :unknown-return code-location. (kind nil :type (member :code-location :function-start :function-end :unknown-return-partner)) ;; ;; Status helps the user and the implementation. (status :inactive :type (member :active :inactive :deleted)) ;; ;; This is a backpointer to a breakpoint-data. (internal-data nil :type (or null breakpoint-data)) ;; ;; With code-locations whose type is :unknown-return, there are really ;; two breakpoints: one at the multiple-value entry point, and one at ;; the single-value entry point. This slot holds the breakpoint for the ;; other one, or NIL if this isn't at an :unknown-return code location. (unknown-return-partner nil :type (or null breakpoint)) ;; ;; :function-end breakpoints use a breakpoint at the :function-start to ;; establish the end breakpoint upon function entry. We do this by frobbing ;; the LRA to jump to a special piece of code that breaks and provides the ;; return values for the returnee. This slot points to the start breakpoint, ;; so we can activate, deactivate, and delete it. (start-helper nil :type (or null breakpoint)) ;; ;; This is a hook users supply to get a dynamically unique cookie for ;; identifying :function-end breakpoint executions. That is, if there is one ;; :function-end breakpoint, but there may be multiple pending calls of its ;; function on the stack. This function takes the cookie, and the ;; hook-function takes the cookie too. (cookie-fun nil :type (or null function)) ;; ;; This slot users can set with whatever information they find useful. %info) ;;; (defun print-breakpoint (obj str n) (declare (ignore n)) (let ((what (breakpoint-what obj))) (format str "#" (etypecase what (code-location what) (debug-function (debug-function-name what))) (etypecase what (code-location nil) (debug-function (breakpoint-kind obj)))))) (setf (documentation 'breakpoint-hook-function 'function) _N"Returns the breakpoint's function the system calls when execution encounters the breakpoint, and it is active. This is SETF'able.") (setf (documentation 'breakpoint-what 'function) _N"Returns the breakpoint's what specification.") (setf (documentation 'breakpoint-kind 'function) _N"Returns the breakpoint's kind specification.") ;;; ;;; Code-locations. ;;; (defstruct (code-location (:print-function print-code-location) (:constructor nil)) ;; ;; This is the debug-function containing code-location. (debug-function nil :type debug-function) ;; ;; This is initially :unsure. Upon first trying to access an :unparsed slot, ;; if the data is unavailable, then this becomes t, and the code-location is ;; unknown. If the data is available, this becomes nil, a known location. ;; We can't use a separate type code-location for this since we must return ;; code-locations before we can tell whether they're known or unknown. For ;; example, when parsing the stack, we don't want to unpack all the variables ;; and blocks just to make frames. (%unknown-p :unsure :type (member t nil :unsure)) ;; ;; This is the debug-block containing code-location. ;; Possibly toss this out and just find it in the blocks cache in ;; debug-function. (%debug-block :unparsed :type (or debug-block (member :unparsed))) ;; ;; This is the number of forms processed by the compiler or loader before ;; the top-level form containing this code-location. (%tlf-offset :unparsed :type (or c::index (member :unparsed))) ;; ;; This is the depth-first number of the node that begins code-location ;; within its top-level form. (%form-number :unparsed :type (or c::index (member :unparsed)))) (defun print-code-location (obj str n) (declare (ignore n)) (format str "#<~A ~S>" (ecase (code-location-unknown-p obj) ((nil) (etypecase obj (compiled-code-location "Compiled-Code-Location") (interpreted-code-location "Interpreted-Code-Location"))) ((t) "Unknown-Code-Location")) (debug-function-name (code-location-debug-function obj)))) (setf (documentation 'code-location-debug-function 'function) _N"Returns the debug-function representing information about the function corresponding to the code-location.") (defstruct (compiled-code-location (:include code-location) (:constructor make-known-code-location (pc debug-function %tlf-offset %form-number %live-set kind &aux (%unknown-p nil))) (:constructor make-compiled-code-location (pc debug-function))) ;; ;; This is an index into debug-function's component slot. (pc nil :type c::index) ;; ;; This is a bit-vector indexed by a variable's position in ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid ;; value at this code-location. (unexported). (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; ;; (unexported) ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)". (kind :unparsed :type (or (member :unparsed) c::location-kind))) (defstruct (interpreted-code-location (:include code-location (%unknown-p nil)) (:constructor make-interpreted-code-location (ir1-node debug-function))) ;; ;; This is an index into debug-function's component slot. (ir1-node nil :type c::node)) ;;; ;;; Debug-sources ;;; (declaim (inline debug-source-root-number)) ;;; (defun debug-source-root-number (debug-source) "Returns the number of top-level forms processed by the compiler before compiling this source. If this source is uncompiled, this is zero. This may be zero even if the source is compiled since the first form in the first file compiled in one compilation, for example, must have a root number of zero -- the compiler saw no other top-level forms before it." (c::debug-source-source-root debug-source)) (setf (documentation 'c::debug-source-from 'function) _N"Returns an indication of the type of source. The following are the possible values: :file from a file (obtained by COMPILE-FILE if compiled). :lisp from Lisp (obtained by COMPILE if compiled). :stream from a non-file stream.") (setf (documentation 'c::debug-source-name 'function) _N"Returns the actual source in some sense represented by debug-source, which is related to DEBUG-SOURCE-FROM: :file the pathname of the file. :lisp a lambda-expression. :stream some descriptive string that's otherwise useless.") (setf (documentation 'c::debug-source-created 'function) _N"Returns the universal time someone created the source. This may be nil if it is unavailable.") (setf (documentation 'c::debug-source-compiled 'function) _N"Returns the time someone compiled the source. This is nil if the source is uncompiled.") (setf (documentation 'c::debug-source-start-positions 'function) _N"This function returns the file position of each top-level form as an array if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp or :stream, this returns nil.") (setf (documentation 'c::debug-source-p 'function) _N"Returns whether object is a debug-source.") ;;;; Frames. ;;; This is used in FIND-ESCAPE-FRAME and with the bogus components and LRAs ;;; used for :function-end breakpoints. When a components debug-info slot is ;;; :bogus-lra, then the real-lra-slot contains the real component to continue ;;; executing, as opposed to the bogus component which appeared in some frame's ;;; LRA location. ;;; (defconstant real-lra-slot vm:code-constants-offset) ;;; These are magically converted by the compiler. ;;; (defun kernel:current-sp () (kernel:current-sp)) (defun kernel:current-fp () (kernel:current-fp)) (defun kernel:stack-ref (s n) (kernel:stack-ref s n)) (defun kernel:%set-stack-ref (s n value) (kernel:%set-stack-ref s n value)) (defun kernel:function-code-header (fun) (kernel:function-code-header fun)) #-gengc (defun kernel:lra-code-header (lra) (kernel:lra-code-header lra)) (defun kernel:make-lisp-obj (value) (kernel:make-lisp-obj value)) (defun kernel:get-lisp-obj-address (thing) (kernel:get-lisp-obj-address thing)) (defun kernel:function-word-offset (fun) (kernel:function-word-offset fun)) ;;; (defsetf kernel:stack-ref kernel:%set-stack-ref) ;;; DESCRIPTOR-SAP -- internal ;;; ;;; Convert the descriptor into a SAP. The bits all stay the same, we just ;;; change our notion of what we think they are. ;;; (declaim (inline descriptor-sap)) (defun descriptor-sap (x) (system:int-sap (kernel:get-lisp-obj-address x))) (declaim (inline cstack-pointer-valid-p)) (defun cstack-pointer-valid-p (x) (declare (type system:system-area-pointer x)) #-(or :x86 :amd64) (and (system:sap< x (kernel:current-sp)) (system:sap<= #-gengc (alien:alien-sap (alien:extern-alien "control_stack" (* t))) #+gengc (kernel:mutator-control-stack-base) x) (zerop (logand (system:sap-int x) #b11))) #+(or :x86 :amd64) ;; stack grows to low address values (and (system:sap>= x (kernel:current-sp)) (system:sap> (alien:alien-sap (alien:extern-alien "control_stack_end" (* t))) x) (zerop (logand (system:sap-int x) #b11)))) #+(or gengc x86 amd64) (alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer) (pc system:system-area-pointer)) #+(or gengc x86 amd64) (defun component-from-component-ptr (component-ptr) (declare (type system:system-area-pointer component-ptr)) (kernel:make-lisp-obj (logior (system:sap-int component-ptr) vm:other-pointer-type))) ;;;; X86 and amd64 support. #+(or x86 amd64) (progn ;;; Note this function should be called with garbage collect inhibited. (defun compute-lra-data-from-pc (pc) (declare (type system-area-pointer pc)) (let ((component-ptr (component-ptr-from-pc pc))) (unless (sap= component-ptr (int-sap #x0)) (let* ((code (component-from-component-ptr component-ptr)) (code-header-len (* (kernel:get-header-data code) vm:word-bytes)) (pc-offset (- (sap-int pc) (- (kernel:get-lisp-obj-address code) vm:other-pointer-type) code-header-len))) ; (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset) (values pc-offset code))))) (defconstant vm::nargs-offset #.vm::ecx-offset) ;;; Check for a valid return address - it could be any valid C/Lisp ;;; address. ;;; ;;; XX Could be a little smarter. (declaim (inline ra-pointer-valid-p)) (defun ra-pointer-valid-p (ra) (declare (type system:system-area-pointer ra)) (and ;; Not the first page which is unmapped. (>= (sys:sap-int ra) 4096) ;; Not a Lisp stack pointer. (or (sys:sap< ra (kernel:current-sp)) (sys:sap>= ra (alien:alien-sap (alien:extern-alien "control_stack_end" (* t))))))) ;;; Try to find a valid previous stack. This is complex on the x86 as ;;; it can jump between C and Lisp frames. To help find a valid frame ;;; it searches backwards. ;;; ;;; XX Should probably check if it has reached the bottom of the ;;; stack. ;;; ;;; XX Should handle interrupted frames, both Lisp and C. A present it ;;; manages to find a fp trail, see linux hack below. ;;; (defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) ; (format t "*CC ~s ~s~%" fp depth) (cond ((not (cstack-pointer-valid-p fp)) (format t "Debug invalid fp ~s~%" fp) nil) (t ;; Check the two possible frame pointers. (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) vm:word-bytes)))) (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset) vm:word-bytes)))) (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes))) (c-ra (sap-ref-sap fp (* 1 vm:word-bytes)))) (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra) (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) (ra-pointer-valid-p c-ra)) ; (format t "*C Both valid ~s ~s ~s ~s~%" ; lisp-ocfp lisp-ra c-ocfp c-ra) ;; Look forward another step to check their validity. (let ((lisp-path-fp (x86-call-context lisp-ocfp :depth (1+ depth))) (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) (cond ((and lisp-path-fp c-path-fp) ;; Both still seem valid - choose the lisp frame. #+nil (when (zerop depth) (format t "Debug: Both still valid ~s ~s ~s ~s~%" lisp-ocfp lisp-ra c-ocfp c-ra)) #+(or darwin freebsd) (if (sap> lisp-ocfp c-ocfp) (values lisp-ra lisp-ocfp) (values c-ra c-ocfp)) #-(or darwin freebsd) (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. ; (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra) (values lisp-ra lisp-ocfp)) (c-path-fp ;; The C convention is looking good. ; (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra) (values c-ra c-ocfp)) (t ;; Neither seems right? ; (format t "Debug: no valid2 fp found ~s ~s~%" ; lisp-ocfp c-ocfp) nil)))) ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra)) ;; The lisp convention is looking good. ; (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra) (values lisp-ra lisp-ocfp)) ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) #-linux (ra-pointer-valid-p c-ra)) ;; The C convention is looking good. ; (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra) (values c-ra c-ocfp)) (t ; (format t "Debug: no valid fp found ~s ~s~%" lisp-ocfp c-ocfp) nil)))))) ) ; end progn x86 amd64 ;;; TOP-FRAME -- Public. ;;; (defun top-frame () "Returns the top frame of the control stack as it was before calling this function." (multiple-value-bind (fp pc) (kernel:%caller-frame-and-pc) (possibly-an-interpreted-frame (compute-calling-frame (descriptor-sap fp) #-gengc pc #+gengc (descriptor-sap pc) nil) nil))) ;;; FLUSH-FRAMES-ABOVE -- public. ;;; (defun flush-frames-above (frame) "Flush all of the frames above FRAME, and renumber all the frames below FRAME." (setf (frame-up frame) nil) (do ((number 0 (1+ number)) (frame frame (frame-%down frame))) ((not (frame-p frame))) (setf (frame-number frame) number))) ;;; FRAME-DOWN -- Public. ;;; ;;; We have to access the old-fp and return-pc out of frame and pass them to ;;; COMPUTE-CALLING-FRAME. ;;; (defun frame-down (frame) "Returns the frame immediately below frame on the stack. When frame is the bottom of the stack, this returns nil." (let ((down (frame-%down frame))) (if (eq down :unparsed) (let* ((real (frame-real-frame frame)) (debug-fun (frame-debug-function real))) (setf (frame-%down frame) (etypecase debug-fun (compiled-debug-function (let ((c-d-f (compiled-debug-function-compiler-debug-fun debug-fun))) (possibly-an-interpreted-frame (compute-calling-frame (descriptor-sap (get-context-value real vm::ocfp-save-offset (c::compiled-debug-function-old-fp c-d-f))) #-gengc (get-context-value real vm::lra-save-offset (c::compiled-debug-function-return-pc c-d-f)) #+gengc (descriptor-sap (get-context-value real vm::ra-save-offset (c::compiled-debug-function-return-pc c-d-f))) frame) frame))) (bogus-debug-function (let ((fp (frame-pointer real))) (when (cstack-pointer-valid-p fp) #+(or x86 amd64) (multiple-value-bind (ra ofp) (x86-call-context fp) (when (and ra ofp) (compute-calling-frame ofp ra frame))) #-(or x86 amd64) (compute-calling-frame #-alpha (system:sap-ref-sap fp (* vm::ocfp-save-offset vm:word-bytes)) #+alpha (kernel::int-sap (system:sap-ref-32 fp (* vm::ocfp-save-offset vm:word-bytes))) #-gengc (kernel:stack-ref fp vm::lra-save-offset) #+gengc (system:sap-ref-sap fp (* vm::ra-save-offset vm:word-bytes)) frame))))))) down))) ;;; GET-CONTEXT-VALUE -- Internal. ;;; ;;; Get the old FP or return PC out of frame. Stack-slot is the standard save ;;; location offset on the stack. Loc is the saved sc-offset describing the ;;; main location. ;;; #-(or x86 amd64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot pointer loc escaped) (kernel:stack-ref pointer stack-slot)))) #+(or x86 amd64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot pointer loc escaped) (ecase stack-slot (#.vm::ocfp-save-offset (kernel:stack-ref pointer stack-slot)) (#.vm::lra-save-offset (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes)))))))) ;;; #-(or x86 amd64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot pointer loc value escaped) (setf (kernel:stack-ref pointer stack-slot) value)))) #+(or x86 amd64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) (let ((pointer (frame-pointer frame)) (escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot pointer loc value escaped) (ecase stack-slot (#.vm::ocfp-save-offset (setf (kernel:stack-ref pointer stack-slot) value)) (#.vm::lra-save-offset (setf (sap-ref-sap pointer (- (* (1+ stack-slot) vm:word-bytes))) value)))))) (defvar *debugging-interpreter* nil "When set, the debugger foregoes making interpreted-frames, so you can debug the functions that manifest the interpreter.") ;;; POSSIBLY-AN-INTERPRETED-FRAME -- Internal. ;;; ;;; This takes a newly computed frame, frame, and the frame above it on the ;;; stack, up-frame, which is possibly nil. Frame is nil when we hit the ;;; bottom of the control stack. When frame represents a call to ;;; EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame to replace frame. ;;; The interpreted frame points to frame. ;;; (defun possibly-an-interpreted-frame (frame up-frame) (if (or (not frame) (not (eq (debug-function-name (frame-debug-function frame)) 'eval::internal-apply-loop)) *debugging-interpreter* (compiled-frame-escaped frame)) frame (flet ((get-var (name location) (let ((vars (di:ambiguous-debug-variables (di:frame-debug-function frame) name))) (when (or (null vars) (> (length vars) 1)) (error (intl:gettext "Zero or more than one ~A variable in ~ EVAL::INTERNAL-APPLY-LOOP?") (string-downcase name))) (if (eq (debug-variable-validity (car vars) location) :valid) (car vars))))) (let* ((code-loc (frame-code-location frame)) (ptr-var (get-var "FRAME-PTR" code-loc)) (node-var (get-var "NODE" code-loc)) (closure-var (get-var "CLOSURE" code-loc))) (if (and ptr-var node-var closure-var) (let* ((node (debug-variable-value node-var frame)) (d-fun (make-interpreted-debug-function (c::block-home-lambda (c::node-block node))))) (make-interpreted-frame (debug-variable-value ptr-var frame) up-frame d-fun (make-interpreted-code-location node d-fun) (frame-number frame) frame (debug-variable-value closure-var frame))) frame))))) #+(or sparc (and x86 (or darwin solaris netbsd)) (and (or x86 amd64) linux)) (defun find-foreign-function-name (address) _"Return a string describing the foreign function near ADDRESS" (let ((addr (sys:sap-int address))) (alien:with-alien ((info (alien:struct dl-info (filename c-call:c-string) (base alien:unsigned) (symbol c-call:c-string) (symbol-address alien:unsigned))) (dladdr (function alien:unsigned alien:unsigned (* (alien:struct dl-info))) :extern "dladdr")) (let ((err (alien:alien-funcall dladdr addr (alien:addr info)))) (cond ((zerop err) _"Foreign function call land") (t (format nil "~A+#x~x [#x~X] ~A" (alien:slot info 'symbol) (- addr (alien:slot info 'symbol-address)) addr (alien:slot info 'filename) ))))))) #-(or sparc (and x86 (or darwin solaris netbsd)) (and (or x86 amd64) linux)) (defun find-foreign-function-name (ra) (declare (ignore ra)) _"Foreign function call land") (defun assembly-routines-p (component) "Return t if COMPONENT contains code from assembly routines." (let ((start (sap-int (kernel:code-instructions component)))) (maphash (lambda (_ addr) (declare (ignore _)) (when (= addr start) (return-from assembly-routines-p t))) lisp::*assembler-routines*))) (defun find-assembly-routine-name (component pc) "Return the name of the assembly routine at offset PC in COMPONENT. The result is a symbol or nil if the routine cannot be found." (let* ((start (sap-int (kernel:code-instructions component))) (end (+ start (* (kernel::%code-code-size component) vm:word-bytes))) (routines `((#:end . ,end)))) ;; collect the assembly routines in the component (maphash (lambda (name addr) (when (<= start addr end) (push (cons name addr) routines))) lisp::*assembler-routines*) ;; sort them and return the name for the routine at PC (let ((routines (sort routines #'< :key #'cdr)) (addr (+ start pc))) (loop for ((r1 . addr1) (r2 . addr2)) on routines while r2 when (<= addr1 addr addr2) return r1)))) ;;; COMPUTE-CALLING-FRAME -- Internal. ;;; ;;; This returns a frame for the one existing in time immediately prior to the ;;; frame referenced by current-fp. This is current-fp's caller or the next ;;; frame down the control stack. If there is no down frame, this returns nil ;;; for the bottom of the stack. Up-frame is the up link for the resulting ;;; frame object, and it is nil when we call this to get the top of the stack. ;;; ;;; The current frame contains the pointer to the temporally previous frame we ;;; want, and the current frame contains the pc at which we will continue ;;; executing upon returning to that previous frame. ;;; ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp calls ;;; into C. In this case, the code object is stored on the stack after the ;;; LRA, and the LRA is the word offset. ;;; #-(or gengc x86 amd64) (intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun compute-calling-frame (caller lra up-frame) (declare (type system:system-area-pointer caller)) (when (cstack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind (word-offset code) (if (ext:fixnump lra) (let ((fp (frame-pointer up-frame))) (values lra (kernel:stack-ref fp (1+ vm::lra-save-offset)))) (values (kernel:get-header-data lra) (kernel:lra-code-header lra))) (if code (values code (* (1+ (- word-offset (kernel:get-header-data code))) vm:word-bytes) nil) (values :foreign-function 0 nil))) (find-escaped-frame caller)) (if (and (kernel:code-component-p code) (eq (kernel:%code-debug-info code) :bogus-lra)) (let ((real-lra (kernel:code-header-ref code real-lra-slot))) (compute-calling-frame caller real-lra up-frame)) (let ((d-fun (case code (:undefined-function (make-bogus-debug-function "The Undefined Function")) (:foreign-function (make-bogus-debug-function (find-foreign-function-name (sys:int-sap (kernel:get-lisp-obj-address lra))))) ((nil) (make-bogus-debug-function "Bogus stack frame")) (t (handler-case (debug-function-from-pc code pc-offset) (no-debug-info () (make-bogus-debug-function (format nil (intl:gettext "no debug info: ~A:~A") code pc-offset)))))))) (make-compiled-frame caller up-frame d-fun (code-location-from-pc d-fun pc-offset escaped) (if up-frame (1+ (frame-number up-frame)) 0) escaped))))))) #+(or x86 amd64) (intl:with-textdomain ("cmucl" "cmucl-x86-vm") (defun compute-calling-frame (caller ra up-frame) (declare (type system:system-area-pointer caller ra)) ; (format t "ccf: ~a ~a ~a~%" caller ra up-frame) (when (cstack-pointer-valid-p caller) ; (format t "ccf2~%") ;; First check for an escaped frame. (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) (cond (code ;; If it's escaped it may be a function end breakpoint ;; trap. ; (format t "ccf2: escaped ~s ~s~%" code pc-offset) (when (and (kernel:code-component-p code) (eq (kernel:%code-debug-info code) :bogus-lra)) ;; If :bogus-lra grab the real lra. (setq pc-offset (kernel:code-header-ref code (1+ real-lra-slot))) (setq code (kernel:code-header-ref code real-lra-slot)) ; (format t "ccf3 :bogus-lra ~s ~s~%" code pc-offset) (assert code))) (t ;; Not escaped (system:without-gcing (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra))) ; (format t "ccf4 ~s ~s~%" code pc-offset) (unless code (setf code :foreign-function pc-offset 0 escaped nil)))) (let ((d-fun (case code (:undefined-function (make-bogus-debug-function "The Undefined Function")) (:foreign-function (make-bogus-debug-function (find-foreign-function-name ra))) ((nil) (make-bogus-debug-function "Bogus stack frame")) (t (handler-case (debug-function-from-pc code pc-offset) (no-debug-info () (make-bogus-debug-function (format nil "no debug info: ~A:~A" code pc-offset)))))))) (make-compiled-frame caller up-frame d-fun (code-location-from-pc d-fun pc-offset escaped) (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) #-(or gengc x86 amd64) (intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun find-escaped-frame (frame-pointer) (declare (type system:system-area-pointer frame-pointer)) (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) (alien:with-alien ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) (let ((scp (alien:deref lisp-interrupt-contexts index))) (when (= (system:sap-int frame-pointer) (vm:sigcontext-register scp vm::cfp-offset)) (system:without-gcing (let ((code (code-object-from-bits (vm:sigcontext-register scp vm::code-offset)))) (when (symbolp code) (return (values code 0 scp))) (let* ((code-header-len (* (kernel:get-header-data code) vm:word-bytes)) (pc-offset (- (system:sap-int (vm:sigcontext-program-counter scp)) (- (kernel:get-lisp-obj-address code) vm:other-pointer-type) code-header-len))) ;; Check to see if we were executing in a branch delay slot. #+(or pmax sgi) ; pmax only (when (logbitp 31 (alien:slot scp 'mips::sc-cause)) (incf pc-offset vm:word-bytes)) #+nil (unless (<= 0 pc-offset (* (kernel:code-header-ref code vm:code-code-size-slot) vm:word-bytes)) ;; We were in an assembly routine. Therefore, use the LRA as ;; the pc. (setf pc-offset (- (vm:sigcontext-register scp vm::lra-offset) (kernel:get-lisp-obj-address code) code-header-len))) (let ((code-size (* (kernel:code-header-ref code vm:code-code-size-slot) vm:word-bytes))) (unless (<= 0 pc-offset code-size) ;; We were in an assembly routine. (multiple-value-bind (new-pc-offset computed-return) (find-pc-from-assembly-fun code scp) (setf pc-offset new-pc-offset) (unless (<= 0 pc-offset code-size) ;; Message here? (setf pc-offset 0))))) (return (if (eq (kernel:%code-debug-info code) :bogus-lra) (let ((real-lra (kernel:code-header-ref code real-lra-slot))) (values (kernel:lra-code-header real-lra) (kernel:get-header-data real-lra) nil)) (values code pc-offset scp)))))))))))) #+(or x86 amd64) (intl:with-textdomain ("cmucl" "cmucl-x86-vm")(defun find-escaped-frame (frame-pointer) (declare (type system:system-area-pointer frame-pointer)) (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil)) (alien:with-alien ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) (let ((scp (alien:deref lisp-interrupt-contexts index))) (when (= (system:sap-int frame-pointer) (vm:sigcontext-register scp vm::cfp-offset)) (system:without-gcing (let* ((component-ptr (component-ptr-from-pc (vm:sigcontext-program-counter scp))) (code (if (sap= component-ptr (int-sap #x0)) nil (component-from-component-ptr component-ptr)))) (when (null code) (return (values code 0 scp))) (let* ((code-header-len (* (kernel:get-header-data code) vm:word-bytes)) (pc-offset (- (system:sap-int (vm:sigcontext-program-counter scp)) (- (kernel:get-lisp-obj-address code) vm:other-pointer-type) code-header-len))) (unless (<= 0 pc-offset (* (kernel:code-header-ref code vm:code-code-size-slot) vm:word-bytes)) ;; We were in an assembly routine. Therefore, use the LRA as ;; the pc. (format t "** pc-offset ~s not in code obj ~s?~%" pc-offset code)) (return (values code pc-offset scp))))))))))) #-(or gengc x86 amd64) (intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun find-pc-from-assembly-fun (code scp) "find the PC" (let ((return-machine-address #-ppc (- (vm:sigcontext-register scp vm::lra-offset) vm:other-pointer-type) #+ppc (vm:sigcontext-lr scp)) (code-header-len (* (kernel:get-header-data code) vm:word-bytes))) (values (- return-machine-address (- (get-lisp-obj-address code) vm:other-pointer-type) code-header-len) return-machine-address)))) ;;; CODE-OBJECT-FROM-BITS -- internal. ;;; ;;; Find the code object corresponding to the object represented by bits and ;;; return it. We assume bogus functions correspond to the ;;; undefined-function. ;;; #-gengc (defun code-object-from-bits (bits) (declare (type (unsigned-byte 32) bits)) (let ((object (kernel:make-lisp-obj bits))) (if (functionp object) (or (kernel:function-code-header object) :undefined-function) (let ((lowtag (kernel:get-lowtag object))) (if (= lowtag vm:other-pointer-type) (let ((type (kernel:get-type object))) (cond ((= type vm:code-header-type) object) ((= type vm:return-pc-header-type) (kernel:lra-code-header object)) (t nil)))))))) ;;; *SAVED-STATE-CHAIN* -- maintained by the C code as a list of saps, each ;;; sap pointing to a saved exception state. ;;; #+gengc (declaim (special kernel::*saved-state-chain*)) #+gengc (defun lookup-trace-table-entry (component pc) (declare (type code-component component) (type unsigned-byte pc)) (let ((tt (system:sap+ (kernel:code-instructions component) (kernel:code-header-ref component vm:code-trace-table-offset-slot))) (end (system:sap+ (kernel:code-instructions component) (* (kernel:%code-code-size component) vm:word-bytes)))) (iterate repeat ((sap tt) (offset 0) (state vm:trace-table-normal)) (cond ((> offset pc) state) ((system:sap< sap end) (let ((entry (system:sap-ref-16 tt 0))) (repeat (system:sap+ sap 2) (+ offset (ldb (byte c::tt-bits-per-offset c::tt-bits-per-state) entry)) (ldb (byte c::tt-bits-per-state 0) entry)))) (t vm:trace-table-normal))))) ;;; EXTRACT-INFO-FROM-STATE -- internal. ;;; ;;; Examine the interrupt state and figure out where we were when the interrupt ;;; hit. Return three values, the debug-function, the pc-offset, and the ;;; control-frame-pointer. ;;; ;;; First, we check to see what component the PC is in the middle of. There ;;; are a couple interesting cases: ;;; ;;; - no component: ;;; we were either in one of the C trampoline routines: ;;; - call_into_lisp ;;; - call_into_c ;;; - undefined_tramp ;;; - closure_tramp ;;; - function_end_breakpoint ;;; aren't ever actually in it, because we copy it into a bogus-lra ;;; component before ever actually using it. ;;; or someone jumped someplace strange, in which case we can't do anything. ;;; - component w/ :ASSEMBLER-ROUTINE for debug-info: ;;; we are in an assembly routine. RA will point back into the regular ;;; component. In order to find the CFP we need to check the trace table: ;;; - normal: CFP will hold the correct stack pointer. ;;; - call-site: OCFP will hold the correct stack pointer. ;;; - prologue & epilogue: not used ;;; - component w/ :BOGUS-LRA for debug-info: ;;; we are in the middle of a function-end-breakpoint. ;;; - regular component: ;;; check the trace table: ;;; - normal: everything fine: PC & CFP hold the info we want. ;;; - call-site: same as normal, except use OCFP for the frame pointer. ;;; - prologue: this frame hasn't been initialized. Use the caller, who ;;; can be found by looking at RA and OCFP. ;;; - epilogue: we are in a world of hurt, because we have trashed the ;;; current frame and can't reliably find the caller. ;;; #+gengc (defun extract-info-from-state (state) (declare (type (alien:alien (* unix:sigcontext)) state) (values debug-function unsigned-byte system:system-area-pointer)) (let* ((pc (vm:sigcontext-program-counter state)) (component-ptr (component-ptr-from-pc pc))) (if (zerop (system:sap-int component-ptr)) ;; We were in one of the trampoline routines or off in the ether. ;; ### Need to figure out which one, and do something better. (values (make-bogus-debug-function "Trampoline routine") 0 (system:int-sap 0)) ;; We have a real component. (let* ((component (component-from-component-ptr component-ptr)) (pc-offset (- (sap- pc component-ptr) (* (kernel:get-header-data component) vm:word-bytes)))) (case (kernel:%code-debug-info component) (:assembler-routine (ecase (lookup-trace-table-entry component pc-offset) (#.vm:trace-table-normal ;; ### Need to do something real. (values (make-bogus-debug-function "Assembler routine.") 0 (system:int-sap (vm:sigcontext-register state vm::cfp-offset)))) (#.vm:trace-table-call-site ;; ### Need to do something real. (values (make-bogus-debug-function "Assembler routine.") 0 (system:int-sap (vm:sigcontext-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue (values (make-bogus-debug-function "Function-Prologue in an assembler routine?") 0 (system:int-sap 0))) (#.vm:trace-table-function-epilogue (values (make-bogus-debug-function "Function-Epilogue in an assembler routine?") 0 (system:int-sap 0))))) (:bogus-lra (values (make-bogus-debug-function "Function-end breakpoing") 0 (system:int-sap 0))) (t (ecase (lookup-trace-table-entry component pc-offset) (#.vm:trace-table-normal (values (debug-function-from-pc component pc-offset) pc-offset (system:int-sap (vm:sigcontext-register state vm::cfp-offset)))) (#.vm:trace-table-call-site (values (debug-function-from-pc component pc-offset) pc-offset (system:int-sap (vm:sigcontext-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue #+nil ;; ### Need to do something real. (let* ((ra (system:int-sap (vm:sigcontext-register state vm::ra-offset))) (caller-ptr (component-ptr-from-pc ra))) ...) (values (make-bogus-debug-function "Interrupted function prologue") 0 (system:int-sap 0))) (#.vm:trace-table-function-epilogue (values (make-bogus-debug-function "Interrupted function epiloge.") 0 (system:int-sap 0)))))))))) ;;; COMPUTE-CALLING-FRAME -- GenGC version. ;;; ;;; Compute the frame that called us. The information we have available is ;;; the old control-frame-pointer and the return-address. ;;; ;;; On the gengc system, there are fewer special cases that compute-calling- ;;; frame needs to take into account. ;;; #+gengc (defun compute-calling-frame (ocfp ra up-frame) (declare (type system:system-area-pointer ocfp ra)) (flet ((make-frame (dfun pc-offset &optional (cfp ocfp) state (chain (if up-frame (compiled-frame-saved-state-chain (frame-real-frame up-frame)) kernel::*saved-state-chain*))) (make-compiled-frame cfp up-frame dfun (code-location-from-pc dfun pc-offset nil) (if up-frame (1+ (frame-number up-frame)) 0) chain state))) (cond ((zerop (system:sap-int ocfp)) ;; If the ocfp is NULL, then we are the first stack frame after an ;; exception (or at the start). (let ((saved-state-chain (if up-frame (compiled-frame-saved-state-chain (frame-real-frame up-frame)) kernel::*saved-state-chain*))) (when saved-state-chain ;; Well, there are more saved states. (let ((state (locally (declare (optimize (inhibit-warnings 3))) (alien:sap-alien (car saved-state-chain) (* unix:sigcontext))))) (multiple-value-bind (dfun pc-offset cfp) (extract-info-from-state state) (make-frame dfun pc-offset cfp state (cdr saved-state-chain))))))) ((cstack-pointer-valid-p ocfp) ;; The ocfp is valid. Find the code component that ra points into. (let ((component-ptr (component-ptr-from-pc ra))) (if (zerop (system:sap-int component-ptr)) ;; There isn't a component. We must have been called from C. (make-frame (make-bogus-debug-function "Foreign function land") 0) ;; There is a component. Figure out what it is. (let ((component (component-from-component-ptr component-ptr))) ;; ### Should check to see if it is a bogus lra. (let* ((pc-offset (- (sap- ra component-ptr) (* (kernel:get-header-data component) vm:word-bytes)))) (make-frame (debug-function-from-pc component pc-offset) pc-offset)))))) (t ;; ocfp isn't NULL and isn't valid: we can't tell anything about the ;; caller. This shouldn't happen, and if it does, do something sane. (make-frame (make-bogus-debug-function "Bogus stack frame") 0))))) ;;; ;;; Frame utilities. ;;; ;;; DEBUG-FUNCTION-FROM-PC -- Internal. ;;; ;;; This returns a compiled-debug-function for code and pc. We fetch the ;;; c::debug-info and run down its function-map to get a ;;; c::compiled-debug-function from the pc. The result only needs to reference ;;; the component, for function constants, and the c::compiled-debug-function. ;;; (defun debug-function-from-pc (component pc) (let ((info (kernel:%code-debug-info component))) (cond ((not info) (cond ((assembly-routines-p component) (make-bogus-debug-function (format nil "assembly routine: ~S" (find-assembly-routine-name component pc)))) (t (debug-signal 'no-debug-info)))) ((eq info :bogus-lra) (make-bogus-debug-function "Function End Breakpoint")) (t (let* ((function-map (get-debug-info-function-map info)) (len (length function-map))) (declare (simple-vector function-map)) (if (= len 1) (make-compiled-debug-function (svref function-map 0) component) (let ((i 1) (elsewhere-p (>= pc (c::compiled-debug-function-elsewhere-pc (svref function-map 0))))) (declare (type c::index i)) (loop (when (or (= i len) (< pc (if elsewhere-p (c::compiled-debug-function-elsewhere-pc (svref function-map (1+ i))) (svref function-map i)))) (return (make-compiled-debug-function (svref function-map (1- i)) component))) (incf i 2))))))))) ;;; CODE-LOCATION-FROM-PC -- Internal. ;;; ;;; This returns a code-location for the compiled-debug-function, debug-fun, ;;; and the pc into its code vector. If we stopped at a breakpoint, find ;;; the code-location for that breakpoint. Otherwise, make an :unsure code ;;; location, so it can be filled in when we figure out what is going on. ;;; (defun code-location-from-pc (debug-fun pc escaped) (or (and (compiled-debug-function-p debug-fun) escaped (let ((data (breakpoint-data (compiled-debug-function-component debug-fun) pc nil))) (when (and data (breakpoint-data-breakpoints data)) (let ((what (breakpoint-what (first (breakpoint-data-breakpoints data))))) (when (compiled-code-location-p what) what))))) (make-compiled-code-location pc debug-fun))) ;;; FRAME-CATCHES -- Public. ;;; (defun frame-catches (frame) "Returns an a-list mapping catch tags to code-locations. These are code-locations at which execution would continue with frame as the top frame if someone threw to the corresponding tag." (let ((catch #-gengc (descriptor-sap lisp::*current-catch-block*) #+gengc (kernel:mutator-current-catch-block)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) (loop (when (zerop (sap-int catch)) (return (nreverse res))) (when (sap= fp #-alpha (system:sap-ref-sap catch (* vm:catch-block-current-cont-slot vm:word-bytes)) #+alpha (kernel::int-sap (system:sap-ref-32 catch (* vm:catch-block-current-cont-slot vm:word-bytes)))) (let* (#-(or gengc x86 amd64) (lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot)) #+(or gengc x86 amd64) (ra (system:sap-ref-sap catch (* vm:catch-block-entry-pc-slot vm:word-bytes))) #-(or x86 amd64) (component (kernel:stack-ref catch vm:catch-block-current-code-slot)) #+(or x86 amd64) (component (component-from-component-ptr (component-ptr-from-pc ra))) (offset #-(or gengc x86 amd64) (* (- (1+ (kernel:get-header-data lra)) (kernel:get-header-data component)) vm:word-bytes) #+gengc (+ (- (system:sap-int ra) (kernel:get-lisp-obj-address component) (kernel:get-header-data component)) vm:other-pointer-type) #+(or x86 amd64) (- (system:sap-int ra) (- (kernel:get-lisp-obj-address component) vm:other-pointer-type) (* (kernel:get-header-data component) vm:word-bytes)))) (push (cons #-(or x86 amd64) (kernel:stack-ref catch vm:catch-block-tag-slot) #+(or x86 amd64) (kernel:make-lisp-obj (system:sap-ref-32 catch (* vm:catch-block-tag-slot vm:word-bytes))) (make-compiled-code-location offset (frame-debug-function frame))) res))) (setf catch #-alpha (system:sap-ref-sap catch (* vm:catch-block-previous-catch-slot vm:word-bytes)) #+alpha (kernel::int-sap (system:sap-ref-32 catch (* vm:catch-block-previous-catch-slot vm:word-bytes))))))) ;;; FRAME-REAL-FRAME -- Internal. ;;; ;;; If an interpreted frame, return the real frame, otherwise frame. ;;; (defun frame-real-frame (frame) (etypecase frame (compiled-frame frame) (interpreted-frame (interpreted-frame-real-frame frame)))) ;;;; Debug-functions. ;;; DO-DEBUG-FUNCTION-BLOCKS -- Public. ;;; (defmacro do-debug-function-blocks ((block-var debug-function &optional result) &body body) "Executes the forms in a context with block-var bound to each debug-block in debug-function successively. Result is an optional form to execute for return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no result form. This signals a no-debug-blocks condition when the debug-function lacks debug-block information." (let ((blocks (gensym)) (i (gensym))) `(let ((,blocks (debug-function-debug-blocks ,debug-function))) (declare (simple-vector ,blocks)) (dotimes (,i (length ,blocks) ,result) (let ((,block-var (svref ,blocks ,i))) ,@body))))) ;;; DO-DEBUG-FUNCTION-VARIABLES -- Public. ;;; (defmacro do-debug-function-variables ((var debug-function &optional result) &body body) "Executes body in a context with var bound to each debug-variable in debug-function. This returns the value of executing result (defaults to nil). This may iterate over only some of debug-function's variables or none depending on debug policy; for example, possibly the compilation only preserved argument information." (let ((vars (gensym)) (i (gensym))) `(let ((,vars (debug-function-debug-variables ,debug-function))) (declare (type (or null simple-vector) ,vars)) (if ,vars (dotimes (,i (length ,vars) ,result) (let ((,var (svref ,vars ,i))) ,@body)) ,result)))) ;;; DEBUG-FUNCTION-FUNCTION -- Public. ;;; (defun debug-function-function (debug-function) "Returns the Common Lisp function associated with the debug-function. This returns nil if the function is unavailable or is non-existent as a user callable function object." (let ((cached-value (debug-function-%function debug-function))) (if (eq cached-value :unparsed) (setf (debug-function-%function debug-function) (etypecase debug-function (compiled-debug-function (let ((component (compiled-debug-function-component debug-function)) (start-pc (c::compiled-debug-function-start-pc (compiled-debug-function-compiler-debug-fun debug-function)))) (do ((entry (kernel:%code-entry-points component) (kernel:%function-next entry))) ((null entry) nil) (when (= start-pc (c::compiled-debug-function-start-pc (compiled-debug-function-compiler-debug-fun (function-debug-function entry)))) (return entry))))) (interpreted-debug-function (c::lambda-eval-info-function (c::leaf-info (interpreted-debug-function-ir1-lambda debug-function)))) (bogus-debug-function nil))) cached-value))) ;;; DEBUG-FUNCTION-NAME -- Public. ;;; (defun debug-function-name (debug-function) "Returns the name of the function represented by debug-function. This may be a string or a cons; do not assume it is a symbol." (etypecase debug-function (compiled-debug-function (c::compiled-debug-function-name (compiled-debug-function-compiler-debug-fun debug-function))) (interpreted-debug-function (c::lambda-name (interpreted-debug-function-ir1-lambda debug-function))) (bogus-debug-function (bogus-debug-function-%name debug-function)))) ;;; FUNCTION-DEBUG-FUNCTION -- Public. ;;; ;;; If LOCAL-NAME is given, try to return the debug function for the ;;; local function (labels or flet). (defun function-debug-function (fun &key local-name) "Returns a debug-function that represents debug information for function." (case (get-type fun) (#.vm:closure-header-type (function-debug-function (%closure-function fun))) (#.vm:funcallable-instance-header-type (cond ((eval:interpreted-function-p fun) (make-interpreted-debug-function (or (eval::interpreted-function-definition fun) (eval::convert-interpreted-fun fun)))) (t (function-debug-function (funcallable-instance-function fun))))) ((#.vm:function-header-type #.vm:closure-function-header-type) (let* ((name (if (and local-name (valid-function-name-p local-name)) local-name (kernel:%function-name fun))) (component (kernel:function-code-header fun)) (res (find-if #'(lambda (x) (and (c::compiled-debug-function-p x) (equal (c::compiled-debug-function-name x) name) (eq (c::compiled-debug-function-kind x) nil))) (get-debug-info-function-map (kernel:%code-debug-info component))))) (if res (make-compiled-debug-function res component) ;; This used to be the non-interpreted branch, but William wrote it ;; to return the debug-fun of fun's XEP instead of fun's debug-fun. ;; The above code does this more correctly, but it doesn't get or ;; eliminate all appropriate cases. It mostly works, and probably ;; works for all named functions anyway. (debug-function-from-pc component (* (- (kernel:function-word-offset fun) (kernel:get-header-data component)) vm:word-bytes))))))) ;;; DEBUG-FUNCTION-KIND -- Public. ;;; (defun debug-function-kind (debug-function) "Returns the kind of the function which is one of :optional, :external, :top-level, :cleanup, nil." (etypecase debug-function (compiled-debug-function (c::compiled-debug-function-kind (compiled-debug-function-compiler-debug-fun debug-function))) (interpreted-debug-function (c::lambda-kind (interpreted-debug-function-ir1-lambda debug-function))) (bogus-debug-function nil))) ;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public. ;;; (defun debug-variable-info-available (debug-function) "Returns whether there is any variable information for debug-function." (not (not (debug-function-debug-variables debug-function)))) ;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public. ;;; (defun debug-function-symbol-variables (debug-function symbol) "Returns a list of debug-variables in debug-function having the same name and package as symbol. If symbol is uninterned, then this returns a list of debug-variables without package names and with the same name as symbol. The result of this function is limited to the availability of variable information in debug-function; for example, possibly debug-function only knows about its arguments." (let ((vars (ambiguous-debug-variables debug-function (symbol-name symbol))) (package (if (symbol-package symbol) (package-name (symbol-package symbol))))) (delete-if (if (stringp package) #'(lambda (var) (let ((p (debug-variable-package var))) (or (not (stringp p)) (string/= p package)))) #'(lambda (var) (stringp (debug-variable-package var)))) vars))) ;;; AMBIGUOUS-DEBUG-VARIABLES -- Public. ;;; (defun ambiguous-debug-variables (debug-function name-prefix-string) "Returns a list of debug-variables in debug-function whose names contain name-prefix-string as an intial substring. The result of this function is limited to the availability of variable information in debug-function; for example, possibly debug-function only knows about its arguments." (declare (simple-string name-prefix-string)) (let ((variables (debug-function-debug-variables debug-function))) (declare (type (or null simple-vector) variables)) (if variables (let* ((len (length variables)) (prefix-len (length name-prefix-string)) (pos (find-variable name-prefix-string variables len)) (res nil)) (when pos ;; Find names from pos to variable's len that contain prefix. (do ((i pos (1+ i))) ((= i len)) (let* ((var (svref variables i)) (name (debug-variable-name var)) (name-len (length name))) (declare (simple-string name)) (when (/= (or (string/= name-prefix-string name :end1 prefix-len :end2 name-len) prefix-len) prefix-len) (return)) (push var res))) (setq res (nreverse res))) res)))) ;;; FIND-VARIABLE -- Internal. ;;; ;;; This returns a position in variables for one containing name as an initial ;;; substring. End is the length of variables if supplied. ;;; (defun find-variable (name variables &optional end) (declare (simple-vector variables) (simple-string name)) (let ((name-len (length name))) (position name variables :test #'(lambda (x y) (let* ((y (debug-variable-name y)) (y-len (length y))) (declare (simple-string y)) (and (>= y-len name-len) (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) ;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public. ;;; (defun debug-function-lambda-list (debug-function) "Returns a list representing the lambda-list for debug-function. The list has the following structure: (required-var1 required-var2 ... (:optional var3 suppliedp-var4) (:optional var5) ... (:rest var6) (:rest var7) ... (:keyword keyword-symbol var8 suppliedp-var9) (:keyword keyword-symbol var10) ... ) Each VARi is a debug-variable; however it may be the symbol :deleted it is unreferenced in debug-function. This signals a lambda-list-unavaliable condition when there is no argument list information." (etypecase debug-function (compiled-debug-function (compiled-debug-function-lambda-list debug-function)) (interpreted-debug-function (interpreted-debug-function-lambda-list debug-function)) (bogus-debug-function nil))) ;;; INTERPRETED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. ;;; ;;; The hard part is when the lambda-list is unparsed. If it is unparsed, ;;; and all the arguments are required, this is still pretty easy; just ;;; whip the appropriate debug-variables into a list. Otherwise, we have ;;; to pick out the funny arguments including any suppliedp variables. In ;;; this situation, the ir1-lambda is an external entry point that takes ;;; arguments users really pass in. It looks at those and computes defaults ;;; and suppliedp variables, ultimately passing everything defined as a ;;; a parameter to the real function as final arguments. If this has to ;;; compute the lambda list, it caches it in debug-function. ;;; (defun interpreted-debug-function-lambda-list (debug-function) (let ((lambda-list (debug-function-%lambda-list debug-function)) (debug-vars (debug-function-debug-variables debug-function)) (ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)) (res nil)) (if (eq lambda-list :unparsed) (flet ((frob (v debug-vars) (if (c::lambda-var-refs v) (find v debug-vars :key #'interpreted-debug-variable-ir1-var) :deleted))) (let ((xep-args (c::lambda-optional-dispatch ir1-lambda))) (if (and xep-args (eq (c::optional-dispatch-main-entry xep-args) ir1-lambda)) ;; ;; There are rest, optional, keyword, and suppliedp vars. (let ((final-args (c::lambda-vars ir1-lambda))) (dolist (xep-arg (c::optional-dispatch-arglist xep-args)) (let ((info (c::lambda-var-arg-info xep-arg)) (final-arg (pop final-args))) (cond (info (case (c::arg-info-kind info) (:required (push (frob final-arg debug-vars) res)) (:keyword (push (list :keyword (c::arg-info-keyword info) (frob final-arg debug-vars)) res)) (:rest (push (list :rest (frob final-arg debug-vars)) res)) (:optional (push (list :optional (frob final-arg debug-vars)) res))) (when (c::arg-info-supplied-p info) (nconc (car res) (list (frob (pop final-args) debug-vars))))) (t (push (frob final-arg debug-vars) res))))) (setf (debug-function-%lambda-list debug-function) (nreverse res))) ;; ;; All required args, so return them in a list. (dolist (v (c::lambda-vars ir1-lambda) (setf (debug-function-%lambda-list debug-function) (nreverse res))) (push (frob v debug-vars) res))))) ;; ;; Everything's unparsed and cached, so return it. lambda-list))) ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. ;;; ;;; If this has to compute the lambda list, it caches it in debug-function. ;;; (defun compiled-debug-function-lambda-list (debug-function) (let ((lambda-list (debug-function-%lambda-list debug-function))) (cond ((eq lambda-list :unparsed) (multiple-value-bind (args argsp) (parse-compiled-debug-function-lambda-list debug-function) (setf (debug-function-%lambda-list debug-function) args) (if argsp args (debug-signal 'lambda-list-unavailable :debug-function debug-function)))) (lambda-list) ((bogus-debug-function-p debug-function) nil) ((c::compiled-debug-function-arguments (compiled-debug-function-compiler-debug-fun debug-function)) ;; If the packed information is there (whether empty or not) as ;; opposed to being nil, then returned our cached value (nil). nil) (t ;; Our cached value is nil, and the packed lambda-list information ;; is nil, so we don't have anything available. (debug-signal 'lambda-list-unavailable :debug-function debug-function))))) ;;; PARSE-COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. ;;; ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a ;;; compiled-debug-function has no lambda-list information cached. It returns ;;; the lambda-list as the first value and whether there was any argument ;;; information as the second value. Therefore, nil and t means there were no ;;; arguments, but nil and nil means there was no argument information. ;;; (defun parse-compiled-debug-function-lambda-list (debug-function) (let ((args (c::compiled-debug-function-arguments (compiled-debug-function-compiler-debug-fun debug-function)))) (cond ((not args) (values nil nil)) ((eq args :minimal) (values (coerce (debug-function-debug-variables debug-function) 'list) t)) (t (let ((vars (debug-function-debug-variables debug-function)) (i 0) (len (length args)) (res nil) (optionalp nil)) (declare (type (or null simple-vector) vars)) (loop (when (>= i len) (return)) (let ((ele (aref args i))) (cond ((symbolp ele) (case ele (c::deleted ;; Deleted required arg at beginning of args array. (push :deleted res)) (c::optional-args (setf optionalp t)) (c::supplied-p ;; supplied-p var immediately following keyword or optional. ;; Stick the extra var in the result element representing ;; the keyword or optional, which is the previous one. (cond ((eq (car res) :deleted)) ; no nothing (t (let ((var (compiled-debug-function-lambda-list-var args (incf i) vars))) (setf (car res) (append (car res) (list var))))))) (c::rest-arg (push (list :rest (compiled-debug-function-lambda-list-var args (incf i) vars)) res)) (c::more-arg ;; Just ignore the fact that the next two args are the ;; more arg context and count, and act like they are ;; regular arguments. nil) (t ;; Keyword arg. (push (list :keyword ele (compiled-debug-function-lambda-list-var args (incf i) vars)) res)))) (optionalp ;; We saw an optional marker, so the following non-symbols are ;; indexes indicating optional variables. (push (list :optional (svref vars ele)) res)) (t ;; Required arg at beginning of args array. (push (svref vars ele) res)))) (incf i)) (values (nreverse res) t)))))) ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal ;;; ;;; Used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST. ;;; (defun compiled-debug-function-lambda-list-var (args i vars) (declare (type (simple-array * (*)) args) (simple-vector vars)) (let ((ele (aref args i))) (cond ((not (symbolp ele)) (svref vars ele)) ((eq ele 'c::deleted) :deleted) (t (error (intl:gettext "Malformed arguments description.")))))) ;;; COMPILED-DEBUG-FUNCTION-DEBUG-INFO -- Internal. ;;; (defun compiled-debug-function-debug-info (debug-fun) (kernel:%code-debug-info (compiled-debug-function-component debug-fun))) ;;;; Unpacking variable and basic block data. (defvar *parsing-buffer* (make-array 20 :adjustable t :fill-pointer t)) (defvar *other-parsing-buffer* (make-array 20 :adjustable t :fill-pointer t)) ;;; ;;; WITH-PARSING-BUFFER -- Internal. ;;; ;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARIABLES and UNCOMPACT-FUNCTION-MAP use ;;; this to unpack binary encoded information. It returns the values returned ;;; by the last form in body. ;;; ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element ;;; zero, and makes sure if we unwind, we nil out any set elements for GC ;;; purposes. ;;; ;;; This also binds other-var to *other-parsing-buffer* when it is supplied, ;;; making sure it starts at element zero and that we nil out any elements if ;;; we unwind. ;;; ;;; This defines the local macro RESULT that takes a buffer, copies its ;;; elements to a resulting simple-vector, nil's out elements, and restarts ;;; the buffer at element zero. RESULT returns the simple-vector. ;;; (eval-when (compile eval) (defmacro with-parsing-buffer ((buffer-var &optional other-var) &body body) (let ((len (gensym)) (res (gensym))) `(unwind-protect (let ((,buffer-var *parsing-buffer*) ,@(if other-var `((,other-var *other-parsing-buffer*)))) (setf (fill-pointer ,buffer-var) 0) ,@(if other-var `((setf (fill-pointer ,other-var) 0))) (macrolet ((result (buf) `(let* ((,',len (length ,buf)) (,',res (make-array ,',len))) (replace ,',res ,buf :end1 ,',len :end2 ,',len) (fill ,buf nil :end ,',len) (setf (fill-pointer ,buf) 0) ,',res))) ,@body)) (fill *parsing-buffer* nil) ,@(if other-var `((fill *other-parsing-buffer* nil)))))) ) ;eval-when ;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal. ;;; ;;; The argument is a debug internals structure. This returns the debug-blocks ;;; for debug-function, regardless of whether we have unpacked them yet. It ;;; signals a no-debug-blocks condition if it can't return the blocks. ;;; (defun debug-function-debug-blocks (debug-function) (let ((blocks (debug-function-blocks debug-function))) (cond ((eq blocks :unparsed) (setf (debug-function-blocks debug-function) (parse-debug-blocks debug-function)) (unless (debug-function-blocks debug-function) (debug-signal 'no-debug-blocks :debug-function debug-function)) (debug-function-blocks debug-function)) (blocks) (t (debug-signal 'no-debug-blocks :debug-function debug-function))))) ;;; PARSE-DEBUG-BLOCKS -- Internal. ;;; ;;; This returns a simple-vector of debug-blocks or nil. Nil indicates there ;;; was no basic block information. ;;; (defun parse-debug-blocks (debug-function) (etypecase debug-function (compiled-debug-function (parse-compiled-debug-blocks debug-function)) (bogus-debug-function (debug-signal 'no-debug-blocks :debug-function debug-function)) (interpreted-debug-function (parse-interpreted-debug-blocks debug-function)))) ;;; PARSE-COMPILED-DEBUG-BLOCKS -- Internal. ;;; ;;; This does some of the work of PARSE-DEBUG-BLOCKS. ;;; (defun parse-compiled-debug-blocks (debug-function) (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) (var-count (length (debug-function-debug-variables debug-function))) (blocks (c::compiled-debug-function-blocks debug-fun)) ;; 8 is a hard-wired constant in the compiler for the element size of ;; the packed binary representation of the blocks data. (live-set-len (ceiling var-count 8)) (tlf-number (c::compiled-debug-function-tlf-number debug-fun))) (unless blocks (return-from parse-compiled-debug-blocks nil)) (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i)))) (with-parsing-buffer (blocks-buffer locations-buffer) (let ((i 0) (len (length blocks)) (last-pc 0)) (loop (when (>= i len) (return)) (let ((succ-and-flags (aref+ blocks i)) (successors nil)) (declare (type (unsigned-byte 8) succ-and-flags) (list successors)) (dotimes (k (ldb c::compiled-debug-block-nsucc-byte succ-and-flags)) (push (c::read-var-integer blocks i) successors)) (let* ((locations (dotimes (k (c::read-var-integer blocks i) (result locations-buffer)) (let ((kind (svref c::compiled-code-location-kinds (aref+ blocks i))) (pc (+ last-pc (c::read-var-integer blocks i))) (tlf-offset (or tlf-number (c::read-var-integer blocks i))) (form-number (c::read-var-integer blocks i)) (live-set (c::read-packed-bit-vector live-set-len blocks i))) (vector-push-extend (make-known-code-location pc debug-function tlf-offset form-number live-set kind) locations-buffer) (setf last-pc pc)))) (block (make-compiled-debug-block locations successors (not (zerop (logand c::compiled-debug-block-elsewhere-p succ-and-flags)))))) (vector-push-extend block blocks-buffer) (dotimes (k (length locations)) (setf (code-location-%debug-block (svref locations k)) block)))))) (let ((res (result blocks-buffer))) (declare (simple-vector res)) (dotimes (i (length res)) (let* ((block (svref res i)) (succs nil)) (dolist (ele (debug-block-successors block)) (push (svref res ele) succs)) (setf (debug-block-successors block) succs))) res))))) ;;; PARSE-INTERPRETED-DEBUG-BLOCKS -- Internal. ;;; ;;; This does some of the work of PARSE-DEBUG-BLOCKS. ;;; (defun parse-interpreted-debug-blocks (debug-function) (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))) (with-parsing-buffer (buffer) (c::do-blocks (block (c::block-component (c::node-block (c::lambda-bind ir1-lambda)))) (when (eq ir1-lambda (c::block-home-lambda block)) (vector-push-extend (make-interpreted-debug-block block) buffer))) (result buffer)))) ;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal. ;;; ;;; The argument is a debug internals structure. This returns nil if there is ;;; no variable information. It returns an empty simple-vector if there were ;;; no locals in the function. Otherwise it returns a simple-vector of ;;; debug-variables. ;;; (defun debug-function-debug-variables (debug-function) (let ((vars (debug-function-debug-vars debug-function))) (if (eq vars :unparsed) (setf (debug-function-debug-vars debug-function) (etypecase debug-function (compiled-debug-function (parse-compiled-debug-variables debug-function)) (bogus-debug-function nil) (interpreted-debug-function (parse-interpreted-debug-variables debug-function)))) vars))) ;;; PARSE-INTERPRETED-DEBUG-VARIABLES -- Internal. ;;; ;;; This grabs all the variables from debug-fun's ir1-lambda, from the IR1 ;;; lambda vars, and all of it's LET's. Each LET is an IR1 lambda. For each ;;; variable, we make an interpreted-debug-variable. We then SORT all the ;;; variables by name. Then we go through, and for any duplicated names we ;;; distinguish the interpreted-debug-variables by setting their id slots to a ;;; distinct number. ;;; (defun parse-interpreted-debug-variables (debug-fun) (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun)) (vars (flet ((frob (ir1-lambda buf) (dolist (v (c::lambda-vars ir1-lambda)) (vector-push-extend (let* ((id (c::leaf-name v)) (pkg (symbol-package id))) (make-interpreted-debug-variable (symbol-name id) (when pkg (package-name pkg)) v)) buf)))) (with-parsing-buffer (buf) (frob ir1-lambda buf) (dolist (let-lambda (c::lambda-lets ir1-lambda)) (frob let-lambda buf)) (result buf))))) (declare (simple-vector vars)) (sort vars #'string< :key #'debug-variable-name) (let ((len (length vars))) (when (> len 1) (let ((i 0) (j 1)) (block PUNT (loop (let* ((var-i (svref vars i)) (var-j (svref vars j)) (name (debug-variable-name var-i))) (when (string= name (debug-variable-name var-j)) (let ((count 1)) (loop (setf (debug-variable-id var-j) count) (when (= (incf j) len) (return-from PUNT)) (setf var-j (svref vars j)) (when (string/= name (debug-variable-name var-j)) (return)) (incf count)))) (setf i j) (incf j) (when (= j len) (return)))))))) vars)) ;;; ASSIGN-MINIMAL-VAR-NAMES -- Internal. ;;; ;;; Vars is the parsed variables for a minimal debug function. We need to ;;; assign names of the form ARG-NNN. We must pad with leading zeros, since ;;; the arguments must be in alphabetical order. ;;; (defun assign-minimal-var-names (vars) (declare (simple-vector vars)) (let* ((len (length vars)) (width (length (format nil "~D" (1- len))))) (dotimes (i len) (setf (compiled-debug-variable-name (svref vars i)) (format nil "ARG-~V,'0D" width i))))) ;;; PARSE-COMPILED-DEBUG-VARIABLES -- Internal. ;;; ;;; This parses the packed binary representation of debug-variables from ;;; debug-function's c::compiled-debug-function. ;;; (defun parse-compiled-debug-variables (debug-function) (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) (packed-vars (c::compiled-debug-function-variables debug-fun)) (default-package (c::compiled-debug-info-package (compiled-debug-function-debug-info debug-function))) (args-minimal (eq (c::compiled-debug-function-arguments debug-fun) :minimal))) (unless packed-vars (return-from parse-compiled-debug-variables nil)) (when (zerop (length packed-vars)) ;; Return a simple-vector not whatever packed-vars may be. (return-from parse-compiled-debug-variables '#())) (let ((i 0) (len (length packed-vars))) (with-parsing-buffer (buffer) (loop ;; The routines in the "C" package are macros that advance the ;; index. (let* ((flags (prog1 (aref packed-vars i) (incf i))) (minimal (logtest c::compiled-debug-variable-minimal-p flags)) (deleted (logtest c::compiled-debug-variable-deleted-p flags)) (name (if minimal "" (c::read-var-string packed-vars i))) (package (cond (minimal default-package) ((logtest c::compiled-debug-variable-packaged flags) (c::read-var-string packed-vars i)) ((logtest c::compiled-debug-variable-uninterned flags) nil) (t default-package))) (id (if (logtest c::compiled-debug-variable-id-p flags) (c::read-var-integer packed-vars i) 0)) (sc-offset (if deleted 0 (c::read-var-integer packed-vars i))) (save-sc-offset (if (logtest c::compiled-debug-variable-save-loc-p flags) (c::read-var-integer packed-vars i) nil))) (assert (not (and args-minimal (not minimal)))) (vector-push-extend (make-compiled-debug-variable name package id (logtest c::compiled-debug-variable-environment-live flags) sc-offset save-sc-offset) buffer)) (when (>= i len) (return))) (let ((res (result buffer))) (when args-minimal (assign-minimal-var-names res)) res))))) ;;;; Unpacking minimal debug functions. (eval-when (compile eval) ;;; MAKE-UNCOMPACTED-DEBUG-FUN -- Internal. ;;; ;;; Sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP. ;;; (defmacro make-uncompacted-debug-fun () '(c::make-compiled-debug-function :name (let ((base (ecase (ldb c::minimal-debug-function-name-style-byte options) (#.c::minimal-debug-function-name-symbol (intern (c::read-var-string map i) (c::compiled-debug-info-package info))) (#.c::minimal-debug-function-name-packaged (let ((pkg (c::read-var-string map i))) (intern (c::read-var-string map i) pkg))) (#.c::minimal-debug-function-name-uninterned (make-symbol (c::read-var-string map i))) (#.c::minimal-debug-function-name-component (c::compiled-debug-info-name info))))) (if (logtest flags c::minimal-debug-function-setf-bit) `(setf ,base) base)) :kind (svref c::minimal-debug-function-kinds (ldb c::minimal-debug-function-kind-byte options)) :variables (when vars-p (let ((len (c::read-var-integer map i))) (prog1 (subseq map i (+ i len)) (incf i len)))) :arguments (when vars-p :minimal) :returns (ecase (ldb c::minimal-debug-function-returns-byte options) (#.c::minimal-debug-function-returns-standard :standard) (#.c::minimal-debug-function-returns-fixed :fixed) (#.c::minimal-debug-function-returns-specified (with-parsing-buffer (buf) (dotimes (idx (c::read-var-integer map i)) (vector-push-extend (c::read-var-integer map i) buf)) (result buf)))) :return-pc (c::read-var-integer map i) :old-fp (c::read-var-integer map i) :nfp (when (logtest flags c::minimal-debug-function-nfp-bit) (c::read-var-integer map i)) :start-pc (progn (setq code-start-pc (+ code-start-pc (c::read-var-integer map i))) (+ code-start-pc (c::read-var-integer map i))) :elsewhere-pc (setq elsewhere-pc (+ elsewhere-pc (c::read-var-integer map i))))) ) ;EVAL-WHEN (compile eval) ;;; UNCOMPACT-FUNCTION-MAP -- Internal ;;; ;;; Return a normal function map derived from a minimal debug info function ;;; map. This involves looping parsing minimal-debug-functions and then ;;; building a vector out of them. ;;; (defun uncompact-function-map (info) (declare (type c::compiled-debug-info info)) (let* ((map (c::compiled-debug-info-function-map info)) (i 0) (len (length map)) (code-start-pc 0) (elsewhere-pc 0)) (declare (type (simple-array (unsigned-byte 8) (*)) map)) (ext:collect ((res)) (loop (when (= i len) (return)) (let* ((options (prog1 (aref map i) (incf i))) (flags (prog1 (aref map i) (incf i))) (vars-p (logtest flags c::minimal-debug-function-variables-bit)) (dfun (make-uncompacted-debug-fun))) (res code-start-pc) (res dfun))) (coerce (cdr (res)) 'simple-vector)))) ;;; This variable maps minimal debug-info function maps to an unpacked version ;;; thereof. ;;; (defvar *uncompacted-function-maps* (make-hash-table :test #'eq)) ;;; GET-DEBUG-INFO-FUNCTION-MAP -- Internal ;;; ;;; Return a function-map for a given compiled-debug-info object. If the ;;; info is minimal, and has not been parsed, then parse it. ;;; (defun get-debug-info-function-map (info) (declare (type c::compiled-debug-info info)) (let ((map (c::compiled-debug-info-function-map info))) (if (simple-vector-p map) map (or (gethash map *uncompacted-function-maps*) (setf (gethash map *uncompacted-function-maps*) (uncompact-function-map info)))))) ;;;; Code-locations. ;;; CODE-LOCATION-UNKNOWN-P -- Public. ;;; ;;; If we're sure of whether code-location is known, return t or nil. If we're ;;; :unsure, then try to fill in the code-location's slots. This determines ;;; whether there is any debug-block information, and if code-location is ;;; known. ;;; ;;; ??? IF this conses closures every time it's called, then break off the ;;; :unsure part to get the HANDLER-CASE into another function. ;;; (defun code-location-unknown-p (basic-code-location) "Returns whether basic-code-location is unknown. It returns nil when the code-location is known." (ecase (code-location-%unknown-p basic-code-location) ((t) t) ((nil) nil) (:unsure (setf (code-location-%unknown-p basic-code-location) (handler-case (not (fill-in-code-location basic-code-location)) (no-debug-blocks () t)))))) ;;; CODE-LOCATION-DEBUG-BLOCK -- Public. ;;; (defun code-location-debug-block (basic-code-location) "Returns the debug-block containing code-location if it is available. Some debug policies inhibit debug-block information, and if none is available, then this signals a no-debug-blocks condition." (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) (etypecase basic-code-location (compiled-code-location (compute-compiled-code-location-debug-block basic-code-location)) (interpreted-code-location (setf (code-location-%debug-block basic-code-location) (make-interpreted-debug-block (c::node-block (interpreted-code-location-ir1-node basic-code-location)))))) block))) ;;; COMPUTE-COMPILED-CODE-LOCATION-DEBUG-BLOCK -- Internal. ;;; ;;; This stores and returns basic-code-location's debug-block. It determines ;;; the correct one using the code-location's pc. This uses ;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information or ;;; signal a 'no-debug-blocks condition. The blocks are sorted by their first ;;; code-location's pc, in ascending order. Therefore, as soon as we find a ;;; block that starts with a pc greater than basic-code-location's pc, we know ;;; the previous block contains the pc. If we get to the last block, then the ;;; code-location is either in the second to last block or the last block, and ;;; we have to be careful in determining this since the last block could be ;;; random code at the end of the function. We have to check for the last ;;; block being random code first to see how to compare the code-location's pc. ;;; (defun compute-compiled-code-location-debug-block (basic-code-location) (let* ((pc (compiled-code-location-pc basic-code-location)) (debug-function (code-location-debug-function basic-code-location)) (blocks (debug-function-debug-blocks debug-function)) (len (length blocks))) (declare (simple-vector blocks)) (setf (code-location-%debug-block basic-code-location) (if (= len 1) (svref blocks 0) (do ((i 1 (1+ i)) (end (1- len))) ((= i end) (let ((last (svref blocks end))) (cond ((debug-block-elsewhere-p last) (if (< pc (c::compiled-debug-function-elsewhere-pc (compiled-debug-function-compiler-debug-fun debug-function))) (svref blocks (1- end)) last)) ((< pc (compiled-code-location-pc (svref (compiled-debug-block-code-locations last) 0))) (svref blocks (1- end))) (t last)))) (declare (type c::index i end)) (when (< pc (compiled-code-location-pc (svref (compiled-debug-block-code-locations (svref blocks i)) 0))) (return (svref blocks (1- i))))))))) ;;; CODE-LOCATION-DEBUG-SOURCE -- Public. ;;; (defun code-location-debug-source (code-location) "Returns the code-location's debug-source." (etypecase code-location (compiled-code-location (let* ((info (compiled-debug-function-debug-info (code-location-debug-function code-location))) (sources (c::compiled-debug-info-source info)) (len (length sources))) (declare (list sources)) (when (zerop len) (debug-signal 'no-debug-blocks :debug-function (code-location-debug-function code-location))) (if (= len 1) (car sources) (do ((prev sources src) (src (cdr sources) (cdr src)) (offset (code-location-top-level-form-offset code-location))) ((null src) (car prev)) (when (< offset (c::debug-source-source-root (car src))) (return (car prev))))))) (interpreted-code-location (first (let ((c::*lexical-environment* (c::make-null-environment))) (c::debug-source-for-info (c::component-source-info (c::block-component (c::node-block (interpreted-code-location-ir1-node code-location)))))))))) ;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public. ;;; (defun code-location-top-level-form-offset (code-location) "Returns the number of top-level forms before the one containing code-location as seen by the compiler in some compilation unit. A compilation unit is not necessarily a single file, see the section on debug-sources." (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (let ((tlf-offset (code-location-%tlf-offset code-location))) (cond ((eq tlf-offset :unparsed) (etypecase code-location (compiled-code-location (unless (fill-in-code-location code-location) ;; This check should be unnecessary. We're missing debug info ;; the compiler should have dumped. (error (intl:gettext "Unknown code location? It should be known."))) (code-location-%tlf-offset code-location)) (interpreted-code-location (setf (code-location-%tlf-offset code-location) (c::source-path-tlf-number (c::node-source-path (interpreted-code-location-ir1-node code-location))))))) (t tlf-offset)))) ;;; CODE-LOCATION-FORM-NUMBER -- Public. ;;; (defun code-location-form-number (code-location) "Returns the number of the form corresponding to code-location. The form number is derived by a walking the subforms of a top-level form in depth-first order." (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (let ((form-num (code-location-%form-number code-location))) (cond ((eq form-num :unparsed) (etypecase code-location (compiled-code-location (unless (fill-in-code-location code-location) ;; This check should be unnecessary. We're missing debug info ;; the compiler should have dumped. (error (intl:gettext "Unknown code location? It should be known."))) (code-location-%form-number code-location)) (interpreted-code-location (setf (code-location-%form-number code-location) (c::source-path-form-number (c::node-source-path (interpreted-code-location-ir1-node code-location))))))) (t form-num)))) ;;; CODE-LOCATION-KIND -- Public ;;; (defun code-location-kind (code-location) "Return the kind of CODE-LOCATION, one of: :interpreted, :unknown-return, :known-return, :internal-error, :non-local-exit, :block-start, :call-site, :single-value-return, :non-local-entry" (when (code-location-unknown-p code-location) (error 'unknown-code-location :code-location code-location)) (etypecase code-location (compiled-code-location (let ((kind (compiled-code-location-kind code-location))) (cond ((not (eq kind :unparsed)) kind) ((not (fill-in-code-location code-location)) ;; This check should be unnecessary. We're missing ;; debug info the compiler should have dumped. (error (intl:gettext "Unknown code location? It should be known."))) (t (compiled-code-location-kind code-location))))) (interpreted-code-location :interpreted))) ;;; COMPILED-CODE-LOCATION-LIVE-SET -- Internal. ;;; ;;; This returns the code-location's live-set if it is available. If there ;;; is no debug-block information, this returns nil. ;;; (defun compiled-code-location-live-set (code-location) (if (code-location-unknown-p code-location) nil (let ((live-set (compiled-code-location-%live-set code-location))) (cond ((eq live-set :unparsed) (unless (fill-in-code-location code-location) ;; This check should be unnecessary. We're missing debug info ;; the compiler should have dumped. (error (intl:gettext "Unknown code location? It should be known."))) (compiled-code-location-%live-set code-location)) (t live-set))))) ;;; CODE-LOCATION= -- Public. ;;; (defun code-location= (obj1 obj2) "Returns whether obj1 and obj2 are the same place in the code." (etypecase obj1 (compiled-code-location (etypecase obj2 (compiled-code-location (and (eq (code-location-debug-function obj1) (code-location-debug-function obj2)) (sub-compiled-code-location= obj1 obj2))) (interpreted-code-location nil))) (interpreted-code-location (etypecase obj2 (compiled-code-location nil) (interpreted-code-location (eq (interpreted-code-location-ir1-node obj1) (interpreted-code-location-ir1-node obj2))))))) ;;; (defun sub-compiled-code-location= (obj1 obj2) (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) ;;; FILL-IN-CODE-LOCATION -- Internal. ;;; ;;; This fills in location's :unparsed slots. It returns t or nil depending on ;;; whether the code-location was known in its debug-function's debug-block ;;; information. This may signal a no-debug-blocks condition due to ;;; DEBUG-FUNCTION-DEBUG-BLOCKS, and it assumes the %unknown-p slot is already ;;; set or going to be set. ;;; (defun fill-in-code-location (code-location) (declare (type compiled-code-location code-location)) (let* ((debug-function (code-location-debug-function code-location)) (blocks (debug-function-debug-blocks debug-function))) (declare (simple-vector blocks)) (dotimes (i (length blocks) nil) (let* ((block (svref blocks i)) (locations (compiled-debug-block-code-locations block))) (declare (simple-vector locations)) (dotimes (j (length locations)) (let ((loc (svref locations j))) (when (sub-compiled-code-location= code-location loc) (setf (code-location-%debug-block code-location) block) (setf (code-location-%tlf-offset code-location) (code-location-%tlf-offset loc)) (setf (code-location-%form-number code-location) (code-location-%form-number loc)) (setf (compiled-code-location-%live-set code-location) (compiled-code-location-%live-set loc)) (setf (compiled-code-location-kind code-location) (compiled-code-location-kind loc)) (return-from fill-in-code-location t)))))))) ;;;; Debug-blocks. ;;; DO-DEBUG-BLOCK-LOCATIONS -- Public. ;;; (defmacro do-debug-block-locations ((code-var debug-block &optional return) &body body) "Executes forms in a context with code-var bound to each code-location in debug-block. This returns the value of executing result (defaults to nil)." (let ((code-locations (gensym)) (i (gensym))) `(let ((,code-locations (debug-block-code-locations ,debug-block))) (declare (simple-vector ,code-locations)) (dotimes (,i (length ,code-locations) ,return) (let ((,code-var (svref ,code-locations ,i))) ,@body))))) ;;; DEBUG-BLOCK-FUNCTION-NAME -- Internal. ;;; (defun debug-block-function-name (debug-block) "Returns the name of the function represented by debug-function. This may be a string or a cons; do not assume it is a symbol." (etypecase debug-block (compiled-debug-block (let ((code-locs (compiled-debug-block-code-locations debug-block))) (declare (simple-vector code-locs)) (if (zerop (length code-locs)) (intl:gettext "??? Can't get name of debug-block's function.") (debug-function-name (code-location-debug-function (svref code-locs 0)))))) (interpreted-debug-block (c::lambda-name (c::block-home-lambda (interpreted-debug-block-ir1-block debug-block)))))) ;;; DEBUG-BLOCK-CODE-LOCATIONS -- Internal. ;;; (defun debug-block-code-locations (debug-block) (etypecase debug-block (compiled-debug-block (compiled-debug-block-code-locations debug-block)) (interpreted-debug-block (interpreted-debug-block-code-locations debug-block)))) ;;; INTERPRETED-DEBUG-BLOCK-CODE-LOCATIONS -- Internal. ;;; (defun interpreted-debug-block-code-locations (debug-block) (let ((code-locs (interpreted-debug-block-locations debug-block))) (if (eq code-locs :unparsed) (with-parsing-buffer (buf) (c::do-nodes (node cont (interpreted-debug-block-ir1-block debug-block)) (vector-push-extend (make-interpreted-code-location node (make-interpreted-debug-function (c::block-home-lambda (c::node-block node)))) buf)) (setf (interpreted-debug-block-locations debug-block) (result buf))) code-locs))) ;;;; Variables. ;;; DEBUG-VARIABLE-SYMBOL -- Public. ;;; (defun debug-variable-symbol (debug-var) "Returns the symbol from interning DEBUG-VARIABLE-NAME in the package named by DEBUG-VARIABLE-PACKAGE." (let ((package (debug-variable-package debug-var))) (if package (intern (debug-variable-name debug-var) package) (make-symbol (debug-variable-name debug-var))))) ;;; DEBUG-VARIABLE-VALID-VALUE -- Public. ;;; (defun debug-variable-valid-value (debug-var frame) "Returns the value stored for debug-variable in frame. If the value is not :valid, then this signals an invalid-value error." (unless (eq (debug-variable-validity debug-var (frame-code-location frame)) :valid) (error 'invalid-value :debug-variable debug-var :frame frame)) (debug-variable-value debug-var frame)) ;;; DEBUG-VARIABLE-VALUE -- Public. ;;; (defun debug-variable-value (debug-var frame) "Returns the value stored for debug-variable in frame. The value may be invalid. This is SETF'able." (etypecase debug-var (compiled-debug-variable (check-type frame compiled-frame) (let ((res (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p res) (c:value-cell-ref res) res))) (interpreted-debug-variable (check-type frame interpreted-frame) (eval::leaf-value-lambda-var (interpreted-code-location-ir1-node (frame-code-location frame)) (interpreted-debug-variable-ir1-var debug-var) (frame-pointer frame) (interpreted-frame-closure frame))))) ;;; ACCESS-COMPILED-DEBUG-VAR-SLOT -- Internal. ;;; ;;; This returns what is stored for the variable represented by debug-var ;;; relative to the frame. This may be an indirect value cell if the ;;; variable is both closed over and set. ;;; (defun access-compiled-debug-var-slot (debug-var frame) (let ((escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot (frame-pointer frame) (compiled-debug-variable-sc-offset debug-var) escaped) (sub-access-debug-var-slot (frame-pointer frame) (or (compiled-debug-variable-save-sc-offset debug-var) (compiled-debug-variable-sc-offset debug-var)))))) ;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal. ;;; #-(or x86 amd64) (intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (vm:sigcontext-register escaped (c:sc-offset-offset sc-offset)))) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) `(if escaped (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) ',format) :invalid-value-for-unescaped-register-storage)) (with-nfp ((var) &body body) `(let ((,var (if escaped (system:int-sap (vm:sigcontext-register escaped vm::nfp-offset)) #-alpha (system:sap-ref-sap fp (* vm::nfp-save-offset vm:word-bytes)) #+alpha (alpha::make-number-stack-pointer (system:sap-ref-32 fp (* vm::nfp-save-offset vm:word-bytes)))))) ,@body))) (ecase (c:sc-offset-scn sc-offset) ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number #+rt #.vm:word-pointer-reg-sc-number) (system:without-gcing (with-escaped-value (val) (kernel:make-lisp-obj val)))) (#.vm:base-char-reg-sc-number (with-escaped-value (val) (code-char val))) (#.vm:sap-reg-sc-number (with-escaped-value (val) (system:int-sap val))) (#.vm:signed-reg-sc-number (with-escaped-value (val) (if (logbitp (1- vm:word-bits) val) (logior val (ash -1 vm:word-bits)) val))) (#.vm:unsigned-reg-sc-number (with-escaped-value (val) val)) (#.vm:non-descriptor-reg-sc-number (error (intl:gettext "Local non-descriptor register access?"))) (#.vm:interior-reg-sc-number (error (intl:gettext "Local interior register access?"))) (#.vm:single-reg-sc-number (escaped-float-value single-float)) (#.vm:double-reg-sc-number (escaped-float-value double-float)) #+long-float (#.vm:long-reg-sc-number (escaped-float-value long-float)) #+double-double (#.vm:double-double-reg-sc-number (if escaped (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-reg-sc-number (if escaped (complex (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'single-float) (vm:sigcontext-float-register escaped (1+ (c:sc-offset-offset sc-offset)) 'single-float)) :invalid-value-for-unescaped-register-storage)) (#.vm:complex-double-reg-sc-number (if escaped (complex (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) #+long-float (#.vm:complex-long-reg-sc-number (if escaped (complex (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'long-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4) 'long-float)) :invalid-value-for-unescaped-register-storage)) #+double-double (#.vm:complex-double-double-reg-sc-number (if escaped (complex (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) 'double-float)) (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #-sparc 2) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3) 'double-float))) :invalid-value-for-unescaped-register-storage)) (#.vm:single-stack-sc-number (with-nfp (nfp) (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) (#.vm:double-stack-sc-number (with-nfp (nfp) (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) #+long-float (#.vm:long-stack-sc-number (with-nfp (nfp) (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) #+double-double (#.vm:double-double-stack-sc-number (with-nfp (nfp) (kernel:%make-double-double-float (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))))) (#.vm:complex-single-stack-sc-number (with-nfp (nfp) (complex (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (system:sap-ref-single nfp (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))))) (#.vm:complex-double-stack-sc-number (with-nfp (nfp) (complex (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))))) #+double-double (#.vm:complex-double-double-stack-sc-number (with-nfp (nfp) (complex (kernel:%make-double-double-float (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (kernel:%make-double-double-float (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 4) vm:word-bytes)) (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 6) vm:word-bytes)))))) #+long-float (#.vm:complex-long-stack-sc-number (with-nfp (nfp) (complex (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (system:sap-ref-long nfp (* (+ (c:sc-offset-offset sc-offset) #+sparc 4) vm:word-bytes))))) (#.vm:control-stack-sc-number (kernel:stack-ref fp (c:sc-offset-offset sc-offset))) (#.vm:base-char-stack-sc-number (with-nfp (nfp) (code-char (system:sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes))))) (#.vm:unsigned-stack-sc-number (with-nfp (nfp) (system:sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) (#.vm:signed-stack-sc-number (with-nfp (nfp) (system:signed-sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))) (#.vm:sap-stack-sc-number (with-nfp (nfp) (system:sap-ref-sap nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)))))))) #+(or x86 amd64) (intl:with-textdomain ("cmucl" "cmucl-x86-vm") (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system:system-area-pointer fp)) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (vm:sigcontext-register escaped (c:sc-offset-offset sc-offset)))) ,@forms) :invalid-value-for-unescaped-register-storage)) (escaped-float-value (format) `(if escaped (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) ',format) :invalid-value-for-unescaped-register-storage)) (escaped-complex-float-value (format) `(if escaped (complex (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) ',format) (vm:sigcontext-float-register escaped (1+ (c:sc-offset-offset sc-offset)) ',format)) :invalid-value-for-unescaped-register-storage)) ;; The debug variable locations are not always valid, and ;; on the x86 locations can contain raw values. To ;; prevent later problems from invalid objects, they are ;; filtered here. (make-valid-lisp-obj (val) `(if (or ;; Fixnum (zerop (logand ,val 3)) ;; Character (and (zerop (logand ,val #xffff0000)) ; Top bits zero (= (logand ,val #xff) vm:base-char-type)) ; Char tag ;; Unbound marker. (= ,val vm:unbound-marker-type) ;; Pointer (and (logand ,val 1) ;; Check that the pointer is valid. X Could do a ;; better job. (or (< (lisp::read-only-space-start) ,val (* lisp::*read-only-space-free-pointer* vm:word-bytes)) (< (lisp::static-space-start) ,val (* lisp::*static-space-free-pointer* vm:word-bytes)) (< (lisp::current-dynamic-space-start) ,val (sap-int (kernel:dynamic-space-free-pointer)))))) (kernel:make-lisp-obj ,val) :invalid-object))) (ecase (c:sc-offset-scn sc-offset) ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number) (system:without-gcing (with-escaped-value (val) (make-valid-lisp-obj val)))) (#.vm:base-char-reg-sc-number (with-escaped-value (val) (code-char val))) (#.vm:sap-reg-sc-number (with-escaped-value (val) (system:int-sap val))) (#.vm:signed-reg-sc-number (with-escaped-value (val) (if (logbitp (1- vm:word-bits) val) (logior val (ash -1 vm:word-bits)) val))) (#.vm:unsigned-reg-sc-number (with-escaped-value (val) val)) (#.vm:single-reg-sc-number (escaped-float-value single-float)) (#.vm:double-reg-sc-number (escaped-float-value double-float)) #+long-float (#.vm:long-reg-sc-number (escaped-float-value long-float)) #+double-double (#.vm:double-double-reg-sc-number (if escaped (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-reg-sc-number (escaped-complex-float-value single-float)) (#.vm:complex-double-reg-sc-number (escaped-complex-float-value double-float)) #+long-float (#.vm:complex-long-reg-sc-number (escaped-complex-float-value long-float)) (#.vm:single-stack-sc-number (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes)))) (#.vm:double-stack-sc-number (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes)))) #+long-float (#.vm:long-stack-sc-number (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3) vm:word-bytes)))) #+double-double (#.vm:complex-double-double-reg-sc-number (if escaped (complex (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) 'double-float)) (kernel:%make-double-double-float (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #-sparc 2) 'double-float) (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3) 'double-float))) :invalid-value-for-unescaped-register-storage)) (#.vm:complex-single-stack-sc-number (complex (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (system:sap-ref-single fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))))) (#.vm:complex-double-stack-sc-number (complex (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 4) vm:word-bytes))))) #+long-float (#.vm:complex-long-stack-sc-number (complex (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3) vm:word-bytes))) (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 6) vm:word-bytes))))) #+double-double (#.vm:complex-double-double-stack-sc-number (if escaped (complex (kernel:%make-double-double-float (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 4) vm:word-bytes)))) (kernel:%make-double-double-float (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 6) vm:word-bytes))) (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 8) vm:word-bytes))))) :invalid-value-for-unescaped-register-storage)) #+double-double (#.vm:double-double-stack-sc-number (kernel:%make-double-double-float (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 4) vm:word-bytes))))) (#.vm:control-stack-sc-number (kernel:stack-ref fp (c:sc-offset-offset sc-offset))) (#.vm:base-char-stack-sc-number (code-char (system:sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))))) (#.vm:unsigned-stack-sc-number (system:sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes)))) (#.vm:signed-stack-sc-number (system:signed-sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes)))) (#.vm:sap-stack-sc-number (system:sap-ref-sap fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes)))))))) ;;; %SET-DEBUG-VARIABLE-VALUE -- Internal. ;;; ;;; This stores value as the value of debug-var in frame. In the ;;; compiled-debug-variable case, access the current value to determine if it ;;; is an indirect value cell. This occurs when the variable is both closed ;;; over and set. For interpreted-debug-variables just call ;;; EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter objects. ;;; (defun %set-debug-variable-value (debug-var frame value) (etypecase debug-var (compiled-debug-variable (check-type frame compiled-frame) (let ((current-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p current-value) (c:value-cell-set current-value value) (set-compiled-debug-variable-slot debug-var frame value)))) (interpreted-debug-variable (check-type frame interpreted-frame) (eval::set-leaf-value-lambda-var (interpreted-code-location-ir1-node (frame-code-location frame)) (interpreted-debug-variable-ir1-var debug-var) (frame-pointer frame) (interpreted-frame-closure frame) value))) value) ;;; (defsetf debug-variable-value %set-debug-variable-value) ;;; SET-COMPILED-DEBUG-VARIABLE-SLOT -- Internal. ;;; ;;; This stores value for the variable represented by debug-var relative to the ;;; frame. This assumes the location directly contains the variable's value; ;;; that is, there is no indirect value cell currently there in case the ;;; variable is both closed over and set. ;;; (defun set-compiled-debug-variable-slot (debug-var frame value) (let ((escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot (frame-pointer frame) (compiled-debug-variable-sc-offset debug-var) value escaped) (sub-set-debug-var-slot (frame-pointer frame) (or (compiled-debug-variable-save-sc-offset debug-var) (compiled-debug-variable-sc-offset debug-var)) value)))) ;;; SUB-SET-DEBUG-VAR-SLOT -- Internal. ;;; #-(or x86 amd64) (intl:with-textdomain ("cmucl" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped (setf (vm:sigcontext-register escaped (c:sc-offset-offset sc-offset)) ,val) value)) (set-escaped-float-value (format val) `(if escaped (setf (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) ',format) ,val) value)) (with-nfp ((var) &body body) `(let ((,var (if escaped (system:int-sap (vm:sigcontext-register escaped vm::nfp-offset)) #-alpha (system:sap-ref-sap fp (* vm::nfp-save-offset vm:word-bytes)) #+alpha (alpha::make-number-stack-pointer (system:sap-ref-32 fp (* vm::nfp-save-offset vm:word-bytes)))))) ,@body))) (ecase (c:sc-offset-scn sc-offset) ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number #+rt #.vm:word-pointer-reg-sc-number) (system:without-gcing (set-escaped-value (kernel:get-lisp-obj-address value)))) (#.vm:base-char-reg-sc-number (set-escaped-value (char-code value))) (#.vm:sap-reg-sc-number (set-escaped-value (system:sap-int value))) (#.vm:signed-reg-sc-number (set-escaped-value (logand value (1- (ash 1 vm:word-bits))))) (#.vm:unsigned-reg-sc-number (set-escaped-value value)) (#.vm:non-descriptor-reg-sc-number (error (intl:gettext "Local non-descriptor register access?"))) (#.vm:interior-reg-sc-number (error "Local interior register access?")) (#.vm:single-reg-sc-number (set-escaped-float-value single-float value)) (#.vm:double-reg-sc-number (set-escaped-float-value double-float value)) #+long-float (#.vm:long-reg-sc-number (set-escaped-float-value long-float value)) (#.vm:complex-single-reg-sc-number (when escaped (setf (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'single-float) (realpart value)) (setf (vm:sigcontext-float-register escaped (1+ (c:sc-offset-offset sc-offset)) 'single-float) (imagpart value))) value) (#.vm:complex-double-reg-sc-number (when escaped (setf (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'double-float) (realpart value)) (setf (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1) 'double-float) (imagpart value))) value) #+long-float (#.vm:complex-long-reg-sc-number (when escaped (setf (vm:sigcontext-float-register escaped (c:sc-offset-offset sc-offset) 'long-float) (realpart value)) (setf (vm:sigcontext-float-register escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4) 'long-float) (imagpart value))) value) (#.vm:single-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the single-float value)))) (#.vm:double-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the double-float value)))) #+long-float (#.vm:long-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the long-float value)))) (#.vm:complex-single-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the single-float (realpart value))) (setf (system:sap-ref-single nfp (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes)) (the single-float (realpart value))))) (#.vm:complex-double-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the double-float (realpart value))) (setf (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes)) (the double-float (realpart value))))) #+long-float (#.vm:complex-long-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the long-float (realpart value))) (setf (system:sap-ref-long nfp (* (+ (c:sc-offset-offset sc-offset) #+sparc 4) vm:word-bytes)) (the long-float (realpart value))))) (#.vm:control-stack-sc-number (setf (kernel:stack-ref fp (c:sc-offset-offset sc-offset)) value)) (#.vm:base-char-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (char-code (the character value))))) (#.vm:unsigned-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the (unsigned-byte 32) value)))) (#.vm:signed-stack-sc-number (with-nfp (nfp) (setf (system:signed-sap-ref-32 nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the (signed-byte 32) value)))) (#.vm:sap-stack-sc-number (with-nfp (nfp) (setf (system:sap-ref-sap nfp (* (c:sc-offset-offset sc-offset) vm:word-bytes)) (the system:system-area-pointer value)))))))) #+(or x86 amd64) (intl:with-textdomain ("cmucl" "cmucl-x86-vm") (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped (setf (vm:sigcontext-register escaped (c:sc-offset-offset sc-offset)) ,val) value))) (ecase (c:sc-offset-scn sc-offset) ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number) (system:without-gcing (set-escaped-value (kernel:get-lisp-obj-address value)))) (#.vm:base-char-reg-sc-number (set-escaped-value (char-code value))) (#.vm:sap-reg-sc-number (set-escaped-value (system:sap-int value))) (#.vm:signed-reg-sc-number (set-escaped-value (logand value (1- (ash 1 vm:word-bits))))) (#.vm:unsigned-reg-sc-number (set-escaped-value value)) (#.vm:single-reg-sc-number #+nil ;; don't have escaped floats. (set-escaped-float-value single-float value)) (#.vm:double-reg-sc-number #+nil ;; don't have escaped floats -- still in npx? (set-escaped-float-value double-float value)) #+long-float (#.vm:long-reg-sc-number #+nil ;; don't have escaped floats -- still in npx? (set-escaped-float-value long-float value)) (#.vm:single-stack-sc-number (setf (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (the single-float value))) (#.vm:double-stack-sc-number (setf (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (the double-float value))) #+long-float (#.vm:long-stack-sc-number (setf (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3) vm:word-bytes))) (the long-float value))) (#.vm:complex-single-stack-sc-number (setf (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (realpart (the (complex single-float) value))) (setf (system:sap-ref-single fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (imagpart (the (complex single-float) value)))) (#.vm:complex-double-stack-sc-number (setf (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2) vm:word-bytes))) (realpart (the (complex double-float) value))) (setf (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 4) vm:word-bytes))) (imagpart (the (complex double-float) value)))) #+long-float (#.vm:complex-long-stack-sc-number (setf (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3) vm:word-bytes))) (realpart (the (complex long-float) value))) (setf (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 6) vm:word-bytes))) (imagpart (the (complex long-float) value)))) (#.vm:control-stack-sc-number (setf (kernel:stack-ref fp (c:sc-offset-offset sc-offset)) value)) (#.vm:base-char-stack-sc-number (setf (system:sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (char-code (the character value)))) (#.vm:unsigned-stack-sc-number (setf (system:sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (the (unsigned-byte 32) value))) (#.vm:signed-stack-sc-number (setf (system:signed-sap-ref-32 fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (the (signed-byte 32) value))) (#.vm:sap-stack-sc-number (setf (system:sap-ref-sap fp (- (* (1+ (c:sc-offset-offset sc-offset)) vm:word-bytes))) (the system:system-area-pointer value))))))) (defsetf debug-variable-value %set-debug-variable-value) ;;; INDIRECT-VALUE-CELL-P -- Internal. ;;; ;;; The method for setting and accessing compiled-debug-variable values use ;;; this to determine if the value stored is the actual value or an indirection ;;; cell. ;;; (defun indirect-value-cell-p (x) (and (= (kernel:get-lowtag x) vm:other-pointer-type) (= (kernel:get-type x) vm:value-cell-header-type))) ;;; DEBUG-VARIABLE-VALIDITY -- Public. ;;; ;;; If the variable is always alive, then it is valid. If the code-location is ;;; unknown, then the variable's validity is :unknown. Once we've called ;;; CODE-LOCATION-UNKNOWN-P, we know the live-set information has been cached ;;; in the code-location. ;;; (defun debug-variable-validity (debug-var basic-code-loc) "Returns three values reflecting the validity of debug-variable's value at basic-code-location: :valid The value is known to be available. :invalid The value is known to be unavailable. :unknown The value's availability is unknown." (etypecase debug-var (compiled-debug-variable (compiled-debug-variable-validity debug-var basic-code-loc)) (interpreted-debug-variable (check-type basic-code-loc interpreted-code-location) (let ((validp (rassoc (interpreted-debug-variable-ir1-var debug-var) (c::lexenv-variables (c::node-lexenv (interpreted-code-location-ir1-node basic-code-loc)))))) (if validp :valid :invalid))))) ;;; COMPILED-DEBUG-VARIABLE-VALIDITY -- Internal. ;;; ;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables. ;;; For safety, make sure basic-code-loc is what we think. ;;; (defun compiled-debug-variable-validity (debug-var basic-code-loc) (check-type basic-code-loc compiled-code-location) (cond ((debug-variable-alive-p debug-var) (let ((debug-fun (code-location-debug-function basic-code-loc))) (if (>= (compiled-code-location-pc basic-code-loc) (c::compiled-debug-function-start-pc (compiled-debug-function-compiler-debug-fun debug-fun))) :valid :invalid))) ((code-location-unknown-p basic-code-loc) :unknown) (t (let ((pos (position debug-var (debug-function-debug-variables (code-location-debug-function basic-code-loc))))) (unless pos (error 'unknown-debug-variable :debug-variable debug-var :debug-function (code-location-debug-function basic-code-loc))) ;; There must be live-set info since basic-code-loc is known. (if (zerop (sbit (compiled-code-location-live-set basic-code-loc) pos)) :invalid :valid))))) ;;;; Sources. ;;; Written by Rob Maclachlan. ;;; Documented by Bill Chiles. ;;; ;;; This code produces and uses what we call source-paths. A source-path is a ;;; list whose first element is a form number as returned by ;;; CODE-LOCATION-FORM-NUMBER and whose last element is a top-level-form number ;;; as returned by CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the ;;; last to the first, exclusively, are the numbered subforms into which to ;;; descend. For example: ;;; (defun foo (x) ;;; (let ((a (aref x 3))) ;;; (cons a 3))) ;;; The call to AREF in this example is form number 5. Assuming this DEFUN is ;;; the 11'th top-level-form, the source-path for the AREF call is as follows: ;;; (5 1 0 1 3 11) ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 gets the ;;; first binding, and 1 gets the AREF form. ;;; ;;; Temporary buffer used to build form-number => source-path translation in ;;; FORM-NUMBER-TRANSLATIONS. ;;; (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) ;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS. ;;; (defvar *form-number-circularity-table* (make-hash-table :test #'eq)) ;;; FORM-NUMBER-TRANSLATIONS -- Public. ;;; ;;; The vector elements are in the same format as the compiler's ;;; NODE-SOURCE-PATH; that is, the first element is the form number and the last ;;; is the top-level-form number. ;;; (defun form-number-translations (form tlf-number) "This returns a table mapping form numbers to source-paths. A source-path indicates a descent into the top-level-form form, going directly to the subform corressponding to the form number." (clrhash *form-number-circularity-table*) (setf (fill-pointer *form-number-temp*) 0) (sub-translate-form-numbers form (list tlf-number)) (coerce *form-number-temp* 'simple-vector)) ;;; (defun sub-translate-form-numbers (form path) (unless (gethash form *form-number-circularity-table*) (setf (gethash form *form-number-circularity-table*) t) (vector-push-extend (cons (fill-pointer *form-number-temp*) path) *form-number-temp*) (let ((pos 0) (subform form) (trail form)) (declare (fixnum pos)) (macrolet ((frob () '(progn (when (atom subform) (return)) (let ((fm (car subform))) (when (consp fm) (sub-translate-form-numbers fm (cons pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) (loop (frob) (frob) (setq trail (cdr trail))))))) ;;; SOURCE-PATH-CONTEXT -- Public. ;;; (defun source-path-context (form path context) "Form is a top-level form, and path is a source-path into it. This returns the form indicated by the source-path. Context is the number of enclosing forms to return instead of directly returning the source-path form. When context is non-zero, the form returned contains a marker, #:****HERE****, immediately before the form indicated by path." (declare (type unsigned-byte context)) ;; ;; Get to the form indicated by path or the enclosing form indicated by ;; context and path. (let ((path (reverse (butlast (cdr path))))) (dotimes (i (- (length path) context)) (let ((index (first path))) (unless (and (listp form) (< index (length form))) (error (intl:gettext "Source path no longer exists."))) (setq form (elt form index)) (setq path (rest path)))) ;; ;; Recursively rebuild the source form resulting from the above descent, ;; copying the beginning of each subform up to the next subform we descend ;; into according to path. At the bottom of the recursion, we return the ;; form indicated by path preceded by our marker, and this gets spliced ;; into the resulting list structure on the way back up. (labels ((frob (form path level) (if (or (zerop level) (null path)) (if (zerop context) form `(#:***here*** ,form)) (let ((n (first path))) (unless (and (listp form) (< n (length form))) (error "Source path no longer exists.")) (let ((res (frob (elt form n) (rest path) (1- level)))) (nconc (subseq form 0 n) (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) ;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME. ;;; PREPROCESS-FOR-EVAL -- Public. ;;; ;;; Create a SYMBOL-MACROLET for each variable valid at the location which ;;; accesses that variable from the frame argument. ;;; (defun preprocess-for-eval (form loc) "Return a function of one argument that evaluates form in the lexical context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a no-debug-variables condition when the loc's debug-function has no debug-variable information available. The returned function takes the frame to get values from as its argument, and it returns the values of form. The returned function signals the following conditions: invalid-value, ambiguous-variable-name, and frame-function-mismatch" (declare (type code-location loc)) (let ((n-frame (gensym)) (fun (code-location-debug-function loc))) (unless (debug-variable-info-available fun) ;;; Do we really want to signal this? This prevents the ;;; debugger repl from evaluating other things that might be ;;; useful that doesn't refer to local vars. A warning, ;;; however, might still be useful. #+nil (debug-signal 'no-debug-variables :debug-function fun) (warn (intl:gettext "~&~S has no debug-variable information.") fun)) (ext:collect ((binds) (symbol-macros) (special-binds)) (do-debug-function-variables (var fun) (let ((validity (debug-variable-validity var loc))) (unless (eq validity :invalid) (let* ((sym (debug-variable-symbol var)) (found (assoc sym (binds)))) (if found (setf (second found) :ambiguous) (binds (list sym validity var))))))) (dolist (bind (binds)) (let ((name (first bind)) (var (third bind))) (ecase (second bind) (:valid (let ((binding `(,name (debug-variable-value ',var ,n-frame)))) (if (eq (info variable kind name) :special) (special-binds binding) (symbol-macros binding)))) (:unknown (symbol-macros `(,name (debug-signal 'invalid-value :debug-variable ',var :frame ,n-frame)))) (:ambiguous (symbol-macros `(,name (debug-signal 'ambiguous-variable-name :name ',name :frame ,n-frame))))))) (let ((res (coerce `(lambda (,n-frame) (declare (ignorable ,n-frame)) (let ,(special-binds) (symbol-macrolet ,(symbol-macros) ,form))) 'function))) #'(lambda (frame) ;; This prevents these functions from use in any location other ;; than a function return location, so maybe this should only ;; check whether frame's debug-function is the same as loc's. (unless (code-location= (frame-code-location frame) loc) (debug-signal 'frame-function-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) ;;; EVAL-IN-FRAME -- Public. ;;; (defun eval-in-frame (frame form) (declare (type frame frame)) "Evaluate Form in the lexical context of Frame's current code location, returning the results of the evaluation." (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;; FIND-DEBUG-TAG-FOR-FRAME -- Public. ;;; ;;; helper function, used also by debug:debug-return. (defun find-debug-tag-for-frame (frame) "Find and return the debug catch tag for a given frame, if it exists." (assoc-if #'(lambda (x) (and (symbolp x) (not (symbol-package x)) (string= x :cmucl-debug-catch-tag))) (frame-catches frame))) ;;; RETURN-FROM-FRAME -- Public. ;;; (defun return-from-frame (frame form) (declare (type frame frame)) "Evaluate Form in the lexical context of Frame's current code location, returning from the current frame the results of the evaluation." (let ((tag (find-debug-tag-for-frame frame))) (when tag (throw (car tag) (eval-in-frame frame form))))) ;;;; Breakpoints. ;;; ;;; User visible interface. ;;; (defun make-breakpoint (hook-function what &key (kind :code-location) info function-end-cookie) "This creates and returns a breakpoint. When program execution encounters the breakpoint, the system calls hook-function. Hook-function takes the current frame for the function in which the program is running and the breakpoint object. What and kind determine where in a function the system invokes hook-function. What is either a code-location or a debug-function. Kind is one of :code-location, :function-start, or :function-end. Since the starts and ends of functions may not have code-locations representing them, designate these places by supplying what as a debug-function and kind indicating the :function-start or :function-end. When what is a debug-function and kind is :function-end, then hook-function must take two additional arguments, a list of values returned by the function and a function-end-cookie. Info is information supplied by and used by the user. Function-end-cookie is a function. To implement :function-end breakpoints, the system uses starter breakpoints to establish the :function-end breakpoint for each invocation of the function. Upon each entry, the system creates a unique cookie to identify the invocation, and when the user supplies a function for this argument, the system invokes it on the frame and the cookie. The system later invokes the :function-end breakpoint hook on the same cookie. The user may save the cookie for comparison in the hook function. This signals an error if what is an unknown code-location." (etypecase what (code-location (when (code-location-unknown-p what) (error (intl:gettext "Cannot make a breakpoint at an unknown code location -- ~S.") what)) (assert (eq kind :code-location)) (let ((bpt (%make-breakpoint hook-function what kind info))) (etypecase what (interpreted-code-location (error (intl:gettext "Breakpoints in interpreted code are currently unsupported."))) (compiled-code-location ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. (when (eq (compiled-code-location-kind what) :unknown-return) (let ((other-bpt (%make-breakpoint hook-function what :unknown-return-partner info))) (setf (breakpoint-unknown-return-partner bpt) other-bpt) (setf (breakpoint-unknown-return-partner other-bpt) bpt))))) bpt)) (compiled-debug-function (ecase kind (:function-start (%make-breakpoint hook-function what kind info)) (:function-end (multiple-value-bind (settable known-return) (can-set-function-end-breakpoint-p what) (cond (settable (let* ((bpt (%make-breakpoint hook-function what kind info)) (starter (compiled-debug-function-end-starter what))) (unless starter (setf starter (%make-breakpoint #'list what :function-start nil)) (setf (breakpoint-hook-function starter) (function-end-starter-hook starter what known-return)) (setf (compiled-debug-function-end-starter what) starter)) (setf (breakpoint-start-helper bpt) starter) (push bpt (breakpoint-%info starter)) (setf (breakpoint-cookie-fun bpt) function-end-cookie) bpt)) (t (error (intl:gettext ":FUNCTION-END breakpoints are currently unsupported ~ for the known return convention.")))))))) (interpreted-debug-function (error (intl:gettext ":function-end breakpoints are currently unsupported ~ for interpreted-debug-functions."))))) (defun can-set-function-end-breakpoint-p (what) (typecase what (compiled-debug-function (let ((returns (c::compiled-debug-function-returns (compiled-debug-function-compiler-debug-fun what)))) ;; First value says if we can set the function-end-breakpoint. ;; The second value indicates if this is the known return ;; convention. (values (or (eq returns :standard) (typep returns 'vector)) (not (eq returns :standard))))))) ;;; These are unique objects created upon entry into a function by a ;;; :function-end breakpoint's starter hook. These are only created when users ;;; supply :function-end-cookie to MAKE-BREAKPOINT. Also, the :function-end ;;; breakpoint's hook is called on the same cookie when it is created. ;;; (defstruct (function-end-cookie (:print-function (lambda (obj str n) (declare (ignore obj n)) (write-string "#" str))) (:constructor make-function-end-cookie (bogus-lra debug-fun))) ;; This is a pointer to the bogus-lra created for :function-end bpts. bogus-lra ;; This is the debug-function associated with the cookie. debug-fun) ;;; This maps bogus-lra-components to cookies, so ;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. ;;; (defvar *function-end-cookies* (make-hash-table :test #'eq)) ;;; FUNCTION-END-STARTER-HOOK -- Internal. ;;; ;;; This returns a hook function for the start helper breakpoint associated ;;; with a :function-end breakpoint. The returned function makes a fake LRA ;;; that all returns go through, and this piece of fake code actually breaks. ;;; Upon return from the break, the code provides the returnee with any values. ;;; Since the returned function effectively activates fun-end-bpt on each entry ;;; to debug-fun's function, we must establish breakpoint-data about ;;; fun-end-bpt. ;;; (defun function-end-starter-hook (starter-bpt debug-fun &optional known-return-p) (declare (type breakpoint starter-bpt) (type compiled-debug-function debug-fun)) #'(lambda (frame breakpoint) (declare (ignore breakpoint) (type frame frame)) (let ((lra-sc-offset (c::compiled-debug-function-return-pc (compiled-debug-function-compiler-debug-fun debug-fun)))) (multiple-value-bind (lra component offset) (make-bogus-lra (get-context-value frame #-gengc vm::lra-save-offset #+gengc vm::ra-save-offset lra-sc-offset) known-return-p) (setf (get-context-value frame #-gengc vm::lra-save-offset #+gengc vm::ra-save-offset lra-sc-offset) lra) (let ((end-bpts (breakpoint-%info starter-bpt))) (let ((data (breakpoint-data component offset))) (setf (breakpoint-data-breakpoints data) end-bpts) (dolist (bpt end-bpts) (setf (breakpoint-internal-data bpt) data))) (let ((cookie (make-function-end-cookie lra debug-fun))) (setf (gethash component *function-end-cookies*) cookie) (dolist (bpt end-bpts) (let ((fun (breakpoint-cookie-fun bpt))) (when fun (funcall fun frame cookie)))))))))) ;;; FUNCTION-END-COOKIE-VALID-P -- Public. ;;; (defun function-end-cookie-valid-p (frame cookie) "This takes a function-end-cookie and a frame, and it returns whether the cookie is still valid. A cookie becomes invalid when the frame that established the cookie has exited. Sometimes cookie holders are unaware of cookie invalidation because their :function-end breakpoint hooks didn't run due to THROW'ing. This takes a frame as an efficiency hack since the user probably has a frame object in hand when using this routine, and it saves repeated parsing of the stack and consing when asking whether a series of cookies is valid." (let ((lra (function-end-cookie-bogus-lra cookie)) (lra-sc-offset (c::compiled-debug-function-return-pc (compiled-debug-function-compiler-debug-fun (function-end-cookie-debug-fun cookie))))) (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) (#-(or x86 amd64) eq #+(or x86 amd64) sys:sap= lra (get-context-value frame #-gengc vm::lra-save-offset #+gengc vm::ra-save-offset lra-sc-offset))) (return t))))) ;;; ;;; ACTIVATE-BREAKPOINT. ;;; ;;; ACTIVATE-BREAKPOINT -- Public. ;;; (defun activate-breakpoint (breakpoint) "This causes the system to invoke the breakpoint's hook-function until the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The system invokes breakpoint hook functions in the opposite order that you activate them." (when (eq (breakpoint-status breakpoint) :deleted) (error (intl:gettext "Cannot activate a deleted breakpoint -- ~S.") breakpoint)) (unless (eq (breakpoint-status breakpoint) :active) (ecase (breakpoint-kind breakpoint) (:code-location (let ((loc (breakpoint-what breakpoint))) (etypecase loc (interpreted-code-location (error (intl:gettext "Breakpoints in interpreted code are currently unsupported."))) (compiled-code-location (activate-compiled-code-location-breakpoint breakpoint) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (activate-compiled-code-location-breakpoint other))))))) (:function-start (etypecase (breakpoint-what breakpoint) (compiled-debug-function (activate-compiled-function-start-breakpoint breakpoint)) (interpreted-debug-function (error (intl:gettext "I don't know how you made this, but they're unsupported -- ~S") (breakpoint-what breakpoint))))) (:function-end (etypecase (breakpoint-what breakpoint) (compiled-debug-function (let ((starter (breakpoint-start-helper breakpoint))) (unless (eq (breakpoint-status starter) :active) ;; May already be active by some other :function-end breakpoint. (activate-compiled-function-start-breakpoint starter))) (setf (breakpoint-status breakpoint) :active)) (interpreted-debug-function (error (intl:gettext "I don't know how you made this, but they're unsupported -- ~S") (breakpoint-what breakpoint))))))) breakpoint) ;;; ACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal. ;;; (defun activate-compiled-code-location-breakpoint (breakpoint) (declare (type breakpoint breakpoint)) (let ((loc (breakpoint-what breakpoint))) (declare (type compiled-code-location loc)) (sub-activate-breakpoint breakpoint (breakpoint-data (compiled-debug-function-component (code-location-debug-function loc)) (+ (compiled-code-location-pc loc) (if (or (eq (breakpoint-kind breakpoint) :unknown-return-partner) (eq (compiled-code-location-kind loc) :single-value-return)) vm:single-value-return-byte-offset 0)))))) ;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal. ;;; (defun activate-compiled-function-start-breakpoint (breakpoint) (declare (type breakpoint breakpoint)) (let ((debug-fun (breakpoint-what breakpoint))) (sub-activate-breakpoint breakpoint (breakpoint-data (compiled-debug-function-component debug-fun) (c::compiled-debug-function-start-pc (compiled-debug-function-compiler-debug-fun debug-fun)))))) ;;; SUB-ACTIVATE-BREAKPOINT -- Internal. ;;; (defun sub-activate-breakpoint (breakpoint data) (declare (type breakpoint breakpoint) (type breakpoint-data data)) (setf (breakpoint-status breakpoint) :active) (system:without-interrupts (unless (breakpoint-data-breakpoints data) (setf (breakpoint-data-instruction data) (system:without-gcing (breakpoint-install (kernel:get-lisp-obj-address (breakpoint-data-component data)) (breakpoint-data-offset data))))) (setf (breakpoint-data-breakpoints data) (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) ;;; ;;; DEACTIVATE-BREAKPOINT. ;;; ;;; DEACTIVATE-BREAKPOINT -- Public. ;;; (defun deactivate-breakpoint (breakpoint) "This stops the system from invoking the breakpoint's hook-function." (when (eq (breakpoint-status breakpoint) :active) (system:without-interrupts (let ((loc (breakpoint-what breakpoint))) (etypecase loc ((or interpreted-code-location interpreted-debug-function) (error (intl:gettext "Breakpoints in interpreted code are currently unsupported."))) ((or compiled-code-location compiled-debug-function) (deactivate-compiled-breakpoint breakpoint) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (deactivate-compiled-breakpoint other)))))))) breakpoint) (defun deactivate-compiled-breakpoint (breakpoint) (if (eq (breakpoint-kind breakpoint) :function-end) (let ((starter (breakpoint-start-helper breakpoint))) (unless (find-if #'(lambda (bpt) (and (not (eq bpt breakpoint)) (eq (breakpoint-status bpt) :active))) (breakpoint-%info starter)) (deactivate-compiled-breakpoint starter))) (let* ((data (breakpoint-internal-data breakpoint)) (bpts (delete breakpoint (breakpoint-data-breakpoints data)))) (setf (breakpoint-internal-data breakpoint) nil) (setf (breakpoint-data-breakpoints data) bpts) (unless bpts (system:without-gcing (breakpoint-remove (kernel:get-lisp-obj-address (breakpoint-data-component data)) (breakpoint-data-offset data) (breakpoint-data-instruction data))) (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) ;;; ;;; BREAKPOINT-INFO. ;;; ;;; BREAKPOINT-INFO -- Public. ;;; (defun breakpoint-info (breakpoint) "This returns the user maintained info associated with breakpoint. This is SETF'able." (breakpoint-%info breakpoint)) ;;; (defun %set-breakpoint-info (breakpoint value) (setf (breakpoint-%info breakpoint) value) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-%info other) value)))) ;;; (defsetf breakpoint-info %set-breakpoint-info) ;;; ;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT. ;;; ;;; BREAKPOINT-ACTIVE-P -- Public. ;;; (defun breakpoint-active-p (breakpoint) "This returns whether breakpoint is currently active." (ecase (breakpoint-status breakpoint) (:active t) ((:inactive :deleted) nil))) ;;; DELETE-BREAKPOINT -- Public. ;;; (defun delete-breakpoint (breakpoint) "This frees system storage and removes computational overhead associated with breakpoint. After calling this, breakpoint is completely impotent and can never become active again." (let ((status (breakpoint-status breakpoint))) (unless (eq status :deleted) (when (eq status :active) (deactivate-breakpoint breakpoint)) (setf (breakpoint-status breakpoint) :deleted) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-status other) :deleted))) (when (eq (breakpoint-kind breakpoint) :function-end) (let* ((starter (breakpoint-start-helper breakpoint)) (breakpoints (delete breakpoint (the list (breakpoint-info starter))))) (setf (breakpoint-info starter) breakpoints) (unless breakpoints (delete-breakpoint starter) (setf (compiled-debug-function-end-starter (breakpoint-what breakpoint)) nil)))))) breakpoint) ;;; ;;; C call out stubs. ;;; ;;; BREAKPOINT-INSTALL -- Internal. ;;; ;;; This actually installs the break instruction in the component. It returns ;;; the overwritten bits. You must call this in a context in which GC is ;;; disabled, so Lisp doesn't move objects around that C is pointing to. ;;; (alien:def-alien-routine "breakpoint_install" c-call:unsigned-long (code-obj c-call:unsigned-long) (pc-offset c-call:int)) ;;; BREAKPOINT-REMOVE -- Internal. ;;; ;;; This removes the break instruction and replaces the original instruction. ;;; You must call this in a context in which GC is disabled, so Lisp doesn't ;;; move objects around that C is pointing to. ;;; (alien:def-alien-routine "breakpoint_remove" c-call:void (code-obj c-call:unsigned-long) (pc-offset c-call:int) (old-inst c-call:unsigned-long)) (alien:def-alien-routine "breakpoint_do_displaced_inst" c-call:void (scp (* unix:sigcontext)) (orig-inst c-call:unsigned-long)) ;;; ;;; Breakpoint handlers (layer between C and exported interface). ;;; ;;; This maps components to a mapping of offsets to breakpoint-datas. ;;; (defvar *component-breakpoint-offsets* (make-hash-table :test #'eq)) ;;; BREAKPOINT-DATA -- Internal. ;;; ;;; This returns the breakpoint-data associated with component cross offset. ;;; If none exists, this makes one, installs it, and returns it. ;;; (defun breakpoint-data (component offset &optional (create t)) (flet ((install-breakpoint-data () (when create (let ((data (make-breakpoint-data component offset))) (push (cons offset data) (gethash component *component-breakpoint-offsets*)) data)))) (let ((offsets (gethash component *component-breakpoint-offsets*))) (if offsets (let ((data (assoc offset offsets))) (if data (cdr data) (install-breakpoint-data))) (install-breakpoint-data))))) ;;; DELETE-BREAKPOINT-DATA -- Internal. ;;; ;;; We use this when there are no longer any active breakpoints corresponding ;;; to data. ;;; (defun delete-breakpoint-data (data) (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) (gethash component *component-breakpoint-offsets*) :key #'car))) (if offsets (setf (gethash component *component-breakpoint-offsets*) offsets) (remhash component *component-breakpoint-offsets*))) (ext:undefined-value)) ;;; HANDLE-BREAKPOINT -- Internal Interface. ;;; ;;; The C handler for interrupts calls this when it has a debugging-tool break ;;; instruction. This does NOT handle all breaks; for example, it does not ;;; handle breaks for internal errors. ;;; (defun handle-breakpoint (offset component signal-context) (let ((data (breakpoint-data component offset nil))) (unless data (error (intl:gettext "Unknown breakpoint in ~S at offset ~S.") (debug-function-name (debug-function-from-pc component offset)) offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (if (or (null breakpoints) (eq (breakpoint-kind (car breakpoints)) :function-end)) (handle-function-end-breakpoint-aux breakpoints data signal-context) (handle-breakpoint-aux breakpoints data offset component signal-context))))) ;;; This holds breakpoint-datas while invoking the breakpoint hooks associated ;;; with that particular component and location. While they are executing, if ;;; we hit the location again, we ignore the breakpoint to avoid infinite ;;; recursion. Function-end breakpoints must work differently since the ;;; breakpoint-data is unique for each invocation. ;;; (defvar *executing-breakpoint-hooks* nil) ;;; HANDLE-BREAKPOINT-AUX -- Internal. ;;; ;;; This handles code-location and debug-function :function-start breakpoints. ;;; (intl:with-textdomain ("cmucl" #+(or x86 amd64) "cmucl-x86-vm" #+sparc "cmucl-sparc-vm" #+ppc "cmucl-ppc-vm") (defun handle-breakpoint-aux (breakpoints data offset component signal-context) (unless breakpoints (error (intl:gettext "Breakpoint that nobody wants?"))) (unless (member data *executing-breakpoint-hooks*) (let ((*executing-breakpoint-hooks* (cons data *executing-breakpoint-hooks*))) (invoke-breakpoint-hooks breakpoints component offset))) ;; At this point breakpoints may not hold the same list as ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed a ;; breakpoint deactivation. In fact, if all breakpoints were deactivated ;; then data is invalid since it was deleted and so the correct one must be ;; looked up if it is to be used. If there are no more breakpoints active ;; at this location, then the normal instruction has been put back, and we ;; do not need to do-displaced-inst. (let ((data (breakpoint-data component offset nil))) (when (and data (breakpoint-data-breakpoints data)) ;; There breakpoint is still active, so we need to execute the displaced ;; instruction and leave the breakpoint instruction behind. The best ;; way to do this is different on each machine, so we just leave it up ;; to the C code. (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. #-(or hpux irix x86 amd64) (error (intl:gettext "BREAKPOINT-DO-DISPLACED-INST returned?")))))) (defun invoke-breakpoint-hooks (breakpoints component offset) (let* ((debug-fun (debug-function-from-pc component offset)) (frame (do ((f (top-frame) (frame-down f))) ((eq debug-fun (frame-debug-function f)) f)))) (dolist (bpt breakpoints) (funcall (breakpoint-hook-function bpt) frame ;; If this is an :unknown-return-partner, then pass the ;; hook function the original breakpoint, so that users ;; arn't forced to confront the fact that some breakpoints ;; really are two. (if (eq (breakpoint-kind bpt) :unknown-return-partner) (breakpoint-unknown-return-partner bpt) bpt))))) ;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal Interface ;;; (defun handle-function-end-breakpoint (offset component sigcontext) (let ((data (breakpoint-data component offset nil))) (unless data (error (intl:gettext "Unknown breakpoint in ~S at offset ~S.") (debug-function-name (debug-function-from-pc component offset)) offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) (handle-function-end-breakpoint-aux breakpoints data sigcontext))))) ;;; HANDLE-FUNCTION-END-BREAKPOINT-AUX -- Internal. ;;; ;;; Either HANDLE-BREAKPOINT calls this for :function-end breakpoints [old C ;;; code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly [new C code]. ;;; (defun handle-function-end-breakpoint-aux (breakpoints data signal-context) (delete-breakpoint-data data) (let* ((scp (locally (declare (optimize (ext:inhibit-warnings 3))) (alien:sap-alien signal-context (* unix:sigcontext)))) (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset)) (f (top-frame) (frame-down f))) ((= cfp (system:sap-int (frame-pointer f))) f) (declare (type (unsigned-byte #.vm:word-bits) cfp)))) (component (breakpoint-data-component data)) (cookie (gethash component *function-end-cookies*))) (remhash component *function-end-cookies*) (dolist (bpt breakpoints) (let ((values (get-function-end-breakpoint-values bpt scp))) (funcall (breakpoint-hook-function bpt) frame bpt values cookie))))) ;;; Return a list of return values at the function end breakpoint ;;; BREAKPOINT. ;;; (defun get-function-end-breakpoint-values (breakpoint sigcontext) (let* ((what (breakpoint-what breakpoint)) (returns (c::compiled-debug-function-returns (compiled-debug-function-compiler-debug-fun what)))) (etypecase returns ((member :standard) (function-end-breakpoint-values/standard sigcontext)) (vector (function-end-breakpoint-values/known-return sigcontext returns))))) ;;; Return a list of return values at a breakpoint with standard ;;; return convention. ;;; (defun function-end-breakpoint-values/standard (scp) (let ((ocfp (sigcontext-ocfp-sap scp)) (nargs (kernel:make-lisp-obj (vm:sigcontext-register scp vm::nargs-offset))) (reg-arg-offsets '#.vm::register-arg-offsets) (results nil)) (system:without-gcing (dotimes (arg-num nargs) (push (if reg-arg-offsets (kernel:make-lisp-obj (vm:sigcontext-register scp (pop reg-arg-offsets))) (kernel:stack-ref ocfp arg-num)) results))) (nreverse results))) ;;; Return a list of return values at a breakpoint with known-return ;;; convention. ;;; (defun function-end-breakpoint-values/known-return (sigcontext sc-offsets) (let ((ocfp (sigcontext-ocfp-sap sigcontext))) (loop for offset across sc-offsets collect (sub-access-debug-var-slot ocfp offset sigcontext)))) ;;; Extract the old frame pointer from a sigcontext structure. The ;;; result is a SAP. ;;; (defun sigcontext-ocfp-sap (sigcontext) (system:int-sap (vm:sigcontext-register sigcontext #-(or x86 amd64) vm::ocfp-offset #+(or x86 amd64) vm::ebx-offset))) ;;; ;;; MAKE-BOGUS-LRA (used for :function-end breakpoints) ;;; ;;; (If you change these, look in breakpoint.c too!) (defconstant bogus-lra-constants #-(or x86 amd64) 2 #+(or x86 amd64) 3) (defconstant known-return-p-slot (+ vm:code-constants-offset #-(or x86 amd64) 1 #+(or x86 amd64) 2)) ;;; MAKE-BOGUS-LRA -- Interface. ;;; (defun make-bogus-lra (real-lra &optional known-return-p) "Make a bogus LRA object that signals a breakpoint trap when returned to. If the breakpoint trap handler returns, REAL-LRA is returned to. Three values are returned: the bogus LRA object, the code component it is part of, and the PC offset for the trap instruction." (system:without-gcing (let* ((src-start (system:foreign-symbol-address "function_end_breakpoint_guts" :flavor :data)) (src-end (system:foreign-symbol-address "function_end_breakpoint_end" :flavor :data)) (trap-loc (system:foreign-symbol-address "function_end_breakpoint_trap" :flavor :data)) (length (system:sap- src-end src-start)) (code-object (system:%primitive #-(and (or x86 amd64) gencgc) c:allocate-code-object #+(and (or x86 amd64) gencgc) c::allocate-dynamic-code-object (1+ bogus-lra-constants) length)) (dst-start (kernel:code-instructions code-object))) (declare (type system:system-area-pointer src-start src-end dst-start trap-loc) (type kernel:index length)) (setf (kernel:%code-debug-info code-object) :bogus-lra) (setf (kernel:code-header-ref code-object vm:code-trace-table-offset-slot) length) #-(or x86 amd64) (setf (kernel:code-header-ref code-object real-lra-slot) real-lra) #+(or x86 amd64) (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra) (setf (kernel:code-header-ref code-object real-lra-slot) code) (setf (kernel:code-header-ref code-object (1+ real-lra-slot)) offset)) (setf (kernel:code-header-ref code-object known-return-p-slot) known-return-p) (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits)) (vm:sanctify-for-execution code-object) #+(or x86 amd64) (values dst-start code-object (system:sap- trap-loc src-start)) #-(or x86 amd64) (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start) vm:other-pointer-type)))) (kernel:set-header-data new-lra (logandc2 (+ vm:code-constants-offset bogus-lra-constants 1) 1)) (vm:sanctify-for-execution code-object) (values new-lra code-object (system:sap- trap-loc src-start)))))) ;;;; Editor support. ;;; This holds breakpoints in the slave set on behalf of the editor. ;;; ;(defvar *editor-breakpoints* (make-hash-table :test #'equal)) ;;; ;;; Setting breakpoints. ;;; ;;; SET-BREAKPOINT-FOR-EDITOR -- Internal Interface. ;;; (defun set-breakpoint-for-editor (package name-str path) "The editor calls this remotely in the slave to set breakpoints. Package is the string name of a package or nil, and name-str is a string representing a function name (for example, \"foo\" or \"(setf foo)\"). After finding package, this READs name-str with *package* bound appropriately. Path is either a modified source-path or a symbol (:function-start or :function-end). If it is a modified source-path, it has no top-level-form offset or form-number component, and it is in descent order from the root of the top-level form." (let* ((name (let ((*package* (if package (lisp::package-or-lose package) *package*))) (read-from-string name-str))) (debug-fun (function-debug-function (fdefinition name)))) (etypecase path (symbol (let* ((bpt (di:make-breakpoint #'(lambda (frame bpt) (declare (ignore frame bpt)) (break (intl:gettext "Editor installed breakpoint."))) debug-fun :kind path)) (remote-bpt (wire:make-remote-object bpt))) (activate-breakpoint bpt) ;;(push remote-bpt (gethash name *editor-breakpoints*)) remote-bpt)) (cons (etypecase debug-fun (compiled-debug-function (compiled-debug-function-set-breakpoint-for-editor debug-fun #|name|# path)) (interpreted-debug-function (error (intl:gettext "We don't currently support breakpoints in interpreted code.")))))))) (defun compiled-debug-function-set-breakpoint-for-editor (debug-fun #|name|# path) (let* ((source-paths (generate-component-source-paths (compiled-debug-function-component debug-fun))) (matches nil) (matching-length 0)) (declare (simple-vector source-paths) (list matches) (fixnum matching-length)) ;; Build a list of paths that match path up to matching-length ;; elements. (macrolet ((maybe-store-match (path matched-len) `(cond ((> ,matched-len matching-length) (setf matches (list ,path)) (setf matching-length ,matched-len)) ((= ,matched-len matching-length) (cons ,path matches))))) (dotimes (i (length source-paths)) (declare (fixnum i)) (let ((sp (svref source-paths i))) ;; Remember, first element of sp is a code-location. (do ((path-ptr path (cdr path-ptr)) (sp-ptr (cdr sp) (cdr sp-ptr)) (count 0 (1+ count))) ((or (null path-ptr) (null sp-ptr)) (when (null sp-ptr) (maybe-store-match sp count))) (declare (list sp-ptr path-ptr) (fixnum count)) (unless (= (the fixnum (car path-ptr)) (the fixnum (car sp-ptr))) (maybe-store-match sp count)))))) ;; If there's just one, set it; otherwise, return the conflict set. (cond ((and (= (length matches) 1) (equal path (cdar matches))) (let* ((bpt (make-breakpoint #'(lambda (frame bpt) (declare (ignore frame bpt)) (break (intl:gettext "Editor installed breakpoint."))) (wire:remote-object-value (caar matches)))) (remote-bpt (wire:make-remote-object bpt))) (activate-breakpoint bpt) ;;(push remote-bpt (gethash name *editor-breakpoints*)) remote-bpt)) (t matches)))) ;;; This maps components to vectors of modified source-paths. We assume users ;;; will set multiple breakpoints in a given function which entails computing ;;; this data repeatedly. Possibly the GC hook should free this cache. The ;;; source-paths are modified in the following ways: ;;; 1] The form number element (first) is clobbered with the code-location ;;; corresponding to the source-path. ;;; 2] The top-level-form offset element (last) is thrown away. ;;; 3] Everything after the first element is reversed, so the modified ;;; source-path actually portrays a descent into the form. ;;; (defvar *component-source-locations* (make-hash-table :test #'eq)) ;;; GENERATE-COMPONENT-SOURCE-PATHS -- Internal. ;;; ;;; This returns a vector of modified source-paths, one for every code-location ;;; in component. The source-paths are modified as described for ;;; *component-source-locations*. ;;; (defun generate-component-source-paths (component) (or (gethash component *component-source-locations*) (setf (gethash component *component-source-locations*) (sub-generate-component-source-paths component)))) ;;; This maps source-infos to hashtables that map top-level-form offsets to ;;; modified form-number translations (as returned by ;;; FORM-NUMBER-TRANSLATIONS). These are modified as described for ;;; *component-source-locations*. ;;; (defvar *source-info-offset-translations* (make-hash-table :test #'eq)) ;;; This is a hacking space for SUB-GENERATE-COMPONENT-SOURCE-PATHS. We use ;;; this because we throw away many source-paths we accumulate in this buffer ;;; since they are not associated with code-locations. ;;; (defvar *source-paths-buffer* (make-array 50 :fill-pointer t :adjustable t)) ;;; SUB-GENERATE-COMPONENT-SOURCE-PATHS -- Internal. ;;; ;;; We iterate over the code-locations in component, fetching their ;;; source-infos and using the *source-info-offset-translations* cache. This ;;; computation often repeatedly sees the same source-info/tlf-offset pair, so ;;; we see many source-paths from one form-number-translation table. Because ;;; of this, when we add a form-number-translations table to this cache, we add ;;; all the source-paths in it to the result immediately. Then later if we see ;;; the same (not EQ though) source-info/tlf-offset form-number-translations, ;;; we can simply check if one of the source-paths is already in the result, ;;; and if it is, then all of them already are. We keep the cache around ;;; between invocations since we expect multiple breakpoints to be set in the ;;; same function, and this is why we must check if a form-number-translations ;;; has been added to the result; just its presence in the cache does not mean ;;; it is in the result vector. ;;; (defun sub-generate-component-source-paths (component) (let ((info (kernel:%code-debug-info component))) (unless info (debug-signal 'no-debug-info)) (let* ((function-map (get-debug-info-function-map info)) (result *source-paths-buffer*)) (declare (simple-vector function-map) (vector result)) (setf (fill-pointer result) 0) (flet ((copy-stuff (form-num-trans result) (declare (simple-vector form-num-trans) (vector result)) (dotimes (i (length form-num-trans)) (declare (fixnum i)) (vector-push-extend (svref form-num-trans i) result))) (convert-paths (form-num-trans) (declare (simple-vector form-num-trans)) (dotimes (i (length form-num-trans) form-num-trans) (declare (fixnum i)) (let* ((source-path (svref form-num-trans i))) (declare (list source-path)) ;; Make the first cons point to the reversal of everything ;; else, but throw away what was the last element before the ;; reversal. (setf (cdr source-path) ;; Must copy the rest of the list, so REVERSE, but ;; the first cons cell of each list is unique. (cdr (reverse (cdr source-path)))))))) ;; Get all possible source-paths, modifying any new additions to the ;; cache. (do ((i 0 (+ i 2)) (len (length function-map))) ((>= i len)) (declare (type c::index i)) (let ((d-fun (make-compiled-debug-function (svref function-map i) component))) (do-debug-function-blocks (d-block d-fun) (do-debug-block-locations (loc d-block) (let* ((d-source (code-location-debug-source loc)) (translations (gethash d-source *source-info-offset-translations*)) (tlf-offset (code-location-top-level-form-offset loc)) (loc-num (code-location-form-number loc))) (cond (translations (let ((form-num-trans (gethash tlf-offset translations))) (declare (type (or simple-vector null) form-num-trans)) (cond ((not form-num-trans) (let ((form-num-trans (get-form-number-translations d-source tlf-offset))) (declare (simple-vector form-num-trans)) (setf (gethash tlf-offset translations) form-num-trans) (copy-stuff (convert-paths form-num-trans) result) (setf (car (svref form-num-trans loc-num)) (wire:make-remote-object loc)))) ;; If one of these source-paths is in our result, then ;; they all are. ((find (svref form-num-trans 0) result :test #'eq) (setf (car (svref form-num-trans loc-num)) (wire:make-remote-object loc))) ;; Otherwise, store these source-paths in the result. (t (copy-stuff form-num-trans result) (setf (car (svref form-num-trans loc-num)) (wire:make-remote-object loc)))))) (t (let ((translations (make-hash-table :test #'eq)) (form-num-trans (get-form-number-translations d-source tlf-offset))) (declare (simple-vector form-num-trans)) (setf (gethash d-source *source-info-offset-translations*) translations) (setf (gethash tlf-offset translations) form-num-trans) (copy-stuff (convert-paths form-num-trans) result) (setf (car (svref form-num-trans loc-num)) (wire:make-remote-object loc))))))))))) ;; Copy source-paths with code-locations from the result buffer to a ;; real result vector. (let* ((count (count-if #'(lambda (x) (wire:remote-object-p (car x))) result)) (the-real-thing (make-array count)) (i -1)) (declare (simple-vector the-real-thing) (fixnum i count)) (dotimes (j count) (loop (when (wire:remote-object-p (car (aref result (incf i)))) (return))) (setf (svref the-real-thing j) (aref result i))) the-real-thing)))) ;;; GET-FORM-NUMBER-TRANSLATIONS -- Internal. ;;; ;;; This returns a vector of form-number translations to source-paths for ;;; d-source and the top-level-form indicated by the top-level-form offset. ;;; (defun get-form-number-translations (d-source tlf-offset) (let ((name (debug-source-name d-source))) (ecase (debug-source-from d-source) (:file (cond ((not (probe-file name)) (format t (intl:gettext "~%Cannot set breakpoints for editor when source file no ~ longer exists:~% ~A.") (namestring name))) (t (let* ((local-tlf-offset (- tlf-offset (debug-source-root-number d-source))) (char-offset (aref (or (debug-source-start-positions d-source) (error (intl:gettext "Cannot set breakpoints for editor when ~ there is no start positions map."))) local-tlf-offset))) (with-open-file (f name :external-format (c::debug-source-info d-source)) (cond ((= (debug-source-created d-source) (file-write-date name)) (file-position f char-offset)) (t (format t (intl:gettext "~%While setting a breakpoint for the editor, noticed ~ source file has been modified since compilation:~% ~A~@ Using form offset instead of character position.~%") (namestring name)) (dotimes (i local-tlf-offset) (read f)))) (form-number-translations (read f) tlf-offset)))))) ((:lisp :stream) (form-number-translations (svref name tlf-offset) tlf-offset))))) ;;; SET-LOCATION-BREAKPOINT-FOR-EDITOR -- Internal Interface. ;;; (defun set-location-breakpoint-for-editor (remote-obj-loc) "The editor calls this in the slave with a remote-object representing a code-location to set a breakpoint." (let ((loc (wire:remote-object-value remote-obj-loc))) (etypecase loc (interpreted-code-location (error (intl:gettext "Breakpoints in interpreted code are currently unsupported."))) (compiled-code-location (let* ((bpt (make-breakpoint #'(lambda (frame bpt) (declare (ignore frame bpt)) (break (intl:gettext "Editor installed breakpoint."))) loc)) (remote-bpt (wire:make-remote-object bpt))) (activate-breakpoint bpt) ;;(push remote-bpt (gethash name *editor-breakpoints*)) remote-bpt))))) ;;; ;;; Deleting breakpoints. ;;; ;;; DELETE-BREAKPOINT-FOR-EDITOR -- Internal Interface. ;;; (defun delete-breakpoint-for-editor (remote-obj-bpt) "The editor calls this remotely in the slave to delete a breakpoint." (delete-breakpoint (wire:remote-object-value remote-obj-bpt)) (wire:forget-remote-translation remote-obj-bpt)) ;;;; Miscellaneous ;;; This appears here because it cannot go with the debug-function interface ;;; since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after the debug-function ;;; routines. ;;; ;;; DEBUG-FUNCTION-START-LOCATION -- Public. ;;; (defun debug-function-start-location (debug-fun) "This returns a code-location before the body of a function and after all the arguments are in place. If this cannot determine that location due to a lack of debug information, it returns nil." (etypecase debug-fun (compiled-debug-function (code-location-from-pc debug-fun (c::compiled-debug-function-start-pc (compiled-debug-function-compiler-debug-fun debug-fun)) nil)) (interpreted-debug-function ;; Return the first location if there are any, otherwise nil. (handler-case (do-debug-function-blocks (block debug-fun nil) (do-debug-block-locations (loc block nil) (return-from debug-function-start-location loc))) (no-debug-blocks (condx) (declare (ignore condx)) nil))))) (defun print-code-locations (function) (let ((debug-fun (function-debug-function function))) (do-debug-function-blocks (block debug-fun) (do-debug-block-locations (loc block) (fill-in-code-location loc) (format t (intl:gettext "~S code location at ~D") (compiled-code-location-kind loc) (compiled-code-location-pc loc)) (debug::print-code-location-source-form loc 0) (terpri))))) cmucl-21a/src/code/debug-vm.lisp000066400000000000000000000047351260377556400166720ustar00rootroot00000000000000;;; -*- Package: VM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/debug-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This is some very low-level support for the debugger :function-end ;;; breakpoints. ;;; ;;; Written by William Lott. ;;; (in-package "VM") (intl:textdomain "cmucl") (export '(make-bogus-lra)) (defconstant bogus-lra-constants 2) (defconstant real-lra-slot (+ code-constants-offset 0)) (defconstant known-return-p-slot (+ code-constants-offset 1)) ;;; MAKE-BOGUS-LRA -- Interface. ;;; (defun make-bogus-lra (real-lra &optional known-return-p) "Make a bogus LRA object that signals a breakpoint trap when returned to. If the breakpoint trap handler returns to the fake component, the fake code template returns to real-lra. This returns three values: the bogus LRA object, the code component it points to, and the pc-offset for the trap instruction." (system:without-gcing (let* ((src-start (truly-the system-area-pointer (%primitive foreign-symbol-address "function_end_breakpoint_guts"))) (src-end (truly-the system-area-pointer (%primitive foreign-symbol-address "function_end_breakpoint_end"))) (trap-loc (truly-the system-area-pointer (%primitive foreign-symbol-address "function_end_breakpoint_trap"))) (length (sap- src-end src-start)) (code-object (%primitive allocate-code-object (1+ bogus-lra-constants) length)) (dst-start (code-instructions code-object))) (declare (type system-area-pointer src-start src-end dst-start trap-loc) (type index length)) (setf (code-header-ref code-object code-debug-info-slot) nil) (setf (code-header-ref code-object code-trace-table-offset-slot) length) (setf (code-header-ref code-object real-lra-slot) real-lra) (setf (code-header-ref code-object known-return-p-slot) known-return-p) (system-area-copy src-start 0 dst-start 0 (* length byte-bits)) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) other-pointer-type)))) (kernel:set-header-data new-lra (logandc2 (+ code-constants-offset bogus-lra-constants 1) 1)) (values new-lra code-object (sap- trap-loc src-start)))))) cmucl-21a/src/code/debug.lisp000066400000000000000000001765051260377556400162570ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/debug.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; CMU Common Lisp Debugger. This includes a basic command-line oriented ;;; debugger interface as well as support for Hemlock to deliver debugger ;;; commands to a slave Lisp. ;;; ;;; Written by Bill Chiles. ;;; (in-package "DEBUG") (intl:textdomain "cmucl") (export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors* *debug-print-level* *debug-print-length* *debug-prompt* *default-print-frame-call-verbosity* *debug-readtable* *help-line-scroll-count* *stack-top-hint* *auto-eval-in-frame* var arg *only-block-start-locations* *print-location-kind* do-debug-command)) (in-package "LISP") (export '(invoke-debugger *debugger-hook* step)) (in-package "DEBUG") ;;; ;;; Used to communicate to debug-loop that we are at a step breakpoint. ;;; (define-condition step-condition (simple-condition) ()) ;;;; Variables, parameters, and constants. (defparameter *debug-print-level* 3 "*PRINT-LEVEL* is bound to this value when debug prints a function call. If null, use *PRINT-LEVEL*") (defparameter *debug-print-length* 5 "*PRINT-LENGTH* is bound to this value when debug prints a function call. If null, use *PRINT-LENGTH*.") (defparameter *default-print-frame-call-verbosity* 1 "default value for the verbose argument to print-frame-call. If set to >= 2, source will be printed for all frames") (defvar *in-the-debugger* nil "This is T while in the debugger.") (defvar *debug-command-level* 0 "Pushes and pops/exits inside the debugger change this.") (defvar *stack-top-hint* nil "If this is bound before the debugger is invoked, it is used as the stack top by the debugger.") (defvar *stack-top* nil) (defvar *real-stack-top* nil) (defvar *current-frame* nil) ;;; DEBUG-PROMPT -- Internal. ;;; ;;; This is the default for *debug-prompt*. ;;; (defun debug-prompt () (let ((*standard-output* *debug-io*)) (terpri) (prin1 (di:frame-number *current-frame*)) (dotimes (i *debug-command-level*) (princ "]")) (princ " ") (force-output))) (defparameter *debug-prompt* #'debug-prompt "This is a function of no arguments that prints the debugger prompt on *debug-io*.") (defconstant debug-help-string " The prompt is right square brackets, the number indicating how many recursive command loops you are in. Debug commands do not affect * and friends, but evaluation in the debug loop do affect these variables. Any command may be uniquely abbreviated. Getting in and out of DEBUG: Q throws to top level. GO calls CONTINUE which tries to proceed with the restart 'continue. RESTART invokes restart numbered as shown (prompt if not given). ERROR prints the error condition and restart cases. FLUSH toggles *flush-debug-errors*, which is initially t. The name of any restart, or its number, is a valid command, and is the same as using RESTART to invoke that restart. Changing frames: U up frame D down frame T top frame B bottom frame F n goes to frame n. Inspecting frames: BACKTRACE [n] shows n frames going down the stack. L [prefix] lists locals starting with the given prefix in current function. P displays current function call. PP verbose display of current function, with source. SOURCE [n] displays frame's source form with n levels of enclosing forms. VSOURCE [n] displays frame's source form without any ellipsis. DESCRIBE describe the current function. Breakpoints and steps: LIST-LOCATIONS [{function | :c}] list the locations for breakpoints. Specify :c for the current frame. Abbreviation: LL LIST-BREAKPOINTS list the active breakpoints. Abbreviations: LB, LBP DELETE-BREAKPOINT [n] remove breakpoint n or all breakpoints. Abbreviations: DEL, DBP BREAKPOINT {n | :end | :start} [:break form] [:function function] [{:print form}*] [:condition form] set a breakpoint. Abbreviations: BR, BP STEP [n] step to the next location or step n times. Actions on frames: DEBUG-RETURN expression returns expression's values from the current frame, exiting the debugger. Abbreviations: R Variables: (DEBUG:VAR name [id]) Returns variable's value if possible. If multiple variables with the same name exist, use id to select one (DEBUG:ARG n) Returns the n'th argument's value if possible. Argument zero is the first argument. See the CMU Common Lisp User's Manual for more information. ") ;;;; Breakpoint state: (defvar *only-block-start-locations* nil "When true, the LIST-LOCATIONS command only displays block start locations. Otherwise, all locations are displayed.") (defvar *print-location-kind* nil "If true, list the code location type in the LIST-LOCATIONS command.") ;;; A list of the types of code-locations that should not be stepped to and ;;; should not be listed when listing breakpoints. ;;; (defvar *bad-code-location-types* '(:call-site :internal-error)) (declaim (type list *bad-code-location-types*)) ;;; Code locations of the possible breakpoints ;;; (defvar *possible-breakpoints*) (declaim (type list *possible-breakpoints*)) ;;; A list of the made and active breakpoints, each is a breakpoint-info ;;; structure. ;;; (defvar *breakpoints* nil) (declaim (type list *breakpoints*)) ;;; A list of breakpoint-info structures of the made and active step ;;; breakpoints. ;;; (defvar *step-breakpoints* nil) (declaim (type list *step-breakpoints*)) ;;; Number of times left to step. ;;; (defvar *number-of-steps* 1) (declaim (type integer *number-of-steps*)) ;;; Used when listing and setting breakpoints. ;;; (defvar *default-breakpoint-debug-function* nil) (declaim (type (or list di:debug-function) *default-breakpoint-debug-function*)) ;;;; Code location utilities: ;;; FIRST-CODE-LOCATION -- Internal. ;;; ;;; Returns the first code-location in the passed debug block ;;; (defun first-code-location (debug-block) (let ((found nil) (first-code-location nil)) (di:do-debug-block-locations (code-location debug-block) (unless found (setf first-code-location code-location) (setf found t))) first-code-location)) ;;; NEXT-CODE-LOCATIONS -- Internal. ;;; ;;; Returns a list of the next code-locations following the one passed. One of ;;; the *bad-code-location-types* will not be returned. ;;; (defun next-code-locations (code-location) (let ((debug-block (di:code-location-debug-block code-location)) (block-code-locations nil)) (di:do-debug-block-locations (block-code-location debug-block) (unless (member (di:code-location-kind block-code-location) *bad-code-location-types*) (push block-code-location block-code-locations))) (setf block-code-locations (nreverse block-code-locations)) (let* ((code-loc-list (rest (member code-location block-code-locations :test #'di:code-location=))) (next-list (cond (code-loc-list (list (first code-loc-list))) ((map 'list #'first-code-location (di:debug-block-successors debug-block))) (t nil)))) (when (and (= (length next-list) 1) (di:code-location= (first next-list) code-location)) (setf next-list (next-code-locations (first next-list)))) next-list))) ;;; POSSIBLE-BREAKPOINTS -- Internal. ;;; ;;; Returns a list of code-locations of the possible breakpoints of the ;;; debug-function passed. ;;; (defun possible-breakpoints (debug-function) (let ((possible-breakpoints nil)) (di:do-debug-function-blocks (debug-block debug-function) (unless (di:debug-block-elsewhere-p debug-block) (if *only-block-start-locations* (push (first-code-location debug-block) possible-breakpoints) (di:do-debug-block-locations (code-location debug-block) (when (not (member (di:code-location-kind code-location) *bad-code-location-types*)) (push code-location possible-breakpoints)))))) (nreverse possible-breakpoints))) ;;; LOCATION-IN-LIST -- Internal. ;;; ;;; Searches the info-list for the item passed (code-location, debug-function, ;;; or breakpoint-info). If the item passed is a debug function then kind will ;;; be compared if it was specified. The kind if also compared if a ;;; breakpoint-info is passed since it's in the breakpoint. The info structure ;;; is returned if found. ;;; (defun location-in-list (place info-list &optional (kind nil)) (when (breakpoint-info-p place) (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place))) (setf place (breakpoint-info-place place))) (cond ((di:code-location-p place) (find place info-list :key #'breakpoint-info-place :test #'(lambda (x y) (and (di:code-location-p y) (di:code-location= x y))))) (t (find place info-list :test #'(lambda (x-debug-function y-info) (let ((y-place (breakpoint-info-place y-info)) (y-breakpoint (breakpoint-info-breakpoint y-info))) (and (di:debug-function-p y-place) (eq x-debug-function y-place) (or (not kind) (eq kind (di:breakpoint-kind y-breakpoint)))))))))) ;;; MAYBE-BLOCK-START-LOCATION -- Internal. ;;; ;;; If Loc is an unknown location, then try to find the block start location. ;;; Used by source printing to some information instead of none for the user. ;;; (defun maybe-block-start-location (loc) (if (di:code-location-unknown-p loc) (let* ((block (di:code-location-debug-block loc)) (start (di:do-debug-block-locations (loc block) (return loc)))) (cond ((and (not (di:debug-block-elsewhere-p block)) start) (format t (intl:gettext "~%Unknown location: using block start.~%")) start) (t loc))) loc)) ;;;; The BREAKPOINT-INFO structure: ;;; Hold info about made breakpoints ;;; (defstruct breakpoint-info ;; ;; Where we are going to stop. (place (required-argument) :type (or di:code-location di:debug-function)) ;; ;; The breakpoint returned by di:make-breakpoint. (breakpoint (required-argument) :type di:breakpoint) ;; ;; Function returned from di:preprocess-for-eval. If result is non-nil, ;; drop into the debugger. (break #'identity :type function) ;; ;; Function returned from di:preprocess-for-eval. If result is non-nil, ;; eval (each) print and print results. (condition #'identity :type function) ;; ;; List of functions from di:preprocess-for-eval to evaluate, results are ;; conditionally printed. Car of each element is the function, cdr is the ;; form it goes with. (print nil :type list) ;; ;; The number used when listing the possible breakpoints within a function. ;; Could also be a symbol such as start or end. (code-location-number (required-argument) :type (or symbol integer)) ;; ;; The number used when listing the breakpoints active and to delete ;; breakpoints. (breakpoint-number (required-argument) :type integer)) ;;; CREATE-BREAKPOINT-INFO -- Internal. ;;; ;;; Returns a new breakpoint-info structure with the info passed. ;;; (defun create-breakpoint-info (place breakpoint code-location-number &key (break #'identity) (condition #'identity) (print nil)) (setf *breakpoints* (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) (let ((breakpoint-number (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints))) ((or (> i (length *breakpoints*)) (not (= i (breakpoint-info-breakpoint-number (first breakpoints))))) i)))) (make-breakpoint-info :place place :breakpoint breakpoint :code-location-number code-location-number :breakpoint-number breakpoint-number :break break :condition condition :print print))) ;;; PRINT-BREAKPOINT-INFO -- Internal. ;;; ;;; Prints the breakpoint info for the breakpoint-info structure passed. ;;; (defun print-breakpoint-info (breakpoint-info) (let ((place (breakpoint-info-place breakpoint-info)) (bp-number (breakpoint-info-breakpoint-number breakpoint-info)) (loc-number (breakpoint-info-code-location-number breakpoint-info))) (case (di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) (:code-location (print-code-location-source-form place 0) (format t (intl:gettext "~&~S: ~S in ~S") bp-number loc-number (di:debug-function-name (di:code-location-debug-function place)))) (:function-start (format t (intl:gettext "~&~S: FUNCTION-START in ~S") bp-number (di:debug-function-name place))) (:function-end (format t (intl:gettext "~&~S: FUNCTION-END in ~S") bp-number (di:debug-function-name place)))))) ;;;; Main-hook-function for steps and breakpoints ;;; MAIN-HOOK-FUNCTION -- Internal. ;;; ;;; Must be passed as the hook function. Keeps track of where step ;;; breakpoints are. ;;; (defun main-hook-function (current-frame breakpoint &optional return-vals function-end-cookie) (setf *default-breakpoint-debug-function* (di:frame-debug-function current-frame)) (dolist (step-info *step-breakpoints*) (di:delete-breakpoint (breakpoint-info-breakpoint step-info)) (let ((bp-info (location-in-list step-info *breakpoints*))) (when bp-info (di:activate-breakpoint (breakpoint-info-breakpoint bp-info))))) (let ((*stack-top-hint* current-frame) (step-hit-info (location-in-list (di:breakpoint-what breakpoint) *step-breakpoints* (di:breakpoint-kind breakpoint))) (bp-hit-info (location-in-list (di:breakpoint-what breakpoint) *breakpoints* (di:breakpoint-kind breakpoint))) (break) (condition) (string "")) (setf *step-breakpoints* nil) (labels ((build-string (str) (setf string (concatenate 'string string str))) (print-common-info () (build-string (with-output-to-string (*standard-output*) (when function-end-cookie (format t (intl:gettext "~%Return values: ~S") return-vals)) (when condition (when (breakpoint-info-print bp-hit-info) (format t "~%") (print-frame-call current-frame)) (dolist (print (breakpoint-info-print bp-hit-info)) (format t "~& ~S = ~S" (rest print) (funcall (first print) current-frame)))))))) (when bp-hit-info (setf break (funcall (breakpoint-info-break bp-hit-info) current-frame)) (setf condition (funcall (breakpoint-info-condition bp-hit-info) current-frame))) (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*)) (build-string (format nil (intl:gettext "~&*Step (to a breakpoint)*"))) (print-common-info) (break string)) ((and bp-hit-info step-hit-info break) (build-string (format nil (intl:gettext "~&*Step (to a breakpoint)*"))) (print-common-info) (break string)) ((and bp-hit-info step-hit-info) (print-common-info) (format t "~A" string) (decf *number-of-steps*) (set-step-breakpoint current-frame)) ((and step-hit-info (= 1 *number-of-steps*)) (build-string (intl:gettext "*Step*")) (break (make-condition 'step-condition :format-control string))) (step-hit-info (decf *number-of-steps*) (set-step-breakpoint current-frame)) (bp-hit-info (when break (build-string (format nil (intl:gettext "~&*Breakpoint hit*")))) (print-common-info) (if break (break string) (format t "~A" string))) (t (break (intl:gettext "Error in main-hook-function: unknown breakpoint"))))))) ;;; SET-STEP-BREAKPOINT -- Internal. ;;; ;;; Sets breakpoints at the next possible code-locations. After calling ;;; this either (continue) if in the debugger or just let program flow ;;; return if in a hook function. (defun set-step-breakpoint (frame) (cond ((di:debug-block-elsewhere-p (di:code-location-debug-block (di:frame-code-location frame))) (format t (intl:gettext "Cannot step, in elsewhere code~%"))) (t (let* ((code-location (di:frame-code-location frame)) (next-code-locations (next-code-locations code-location))) (cond (next-code-locations (dolist (code-location next-code-locations) (let ((bp-info (location-in-list code-location *breakpoints*))) (when bp-info (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info)))) (let ((bp (di:make-breakpoint #'main-hook-function code-location :kind :code-location))) (di:activate-breakpoint bp) (push (create-breakpoint-info code-location bp 0) *step-breakpoints*)))) (t (let* ((debug-function (di:frame-debug-function *current-frame*)) (bp (di:make-breakpoint #'main-hook-function debug-function :kind :function-end))) (di:activate-breakpoint bp) (push (create-breakpoint-info debug-function bp 0) *step-breakpoints*)))))))) ;;; STEP-INTERNAL -- Internal. ;;; (defun step-internal (function form) (when (eval:interpreted-function-p function) ;; The stepper currently only supports compiled functions So we ;; try to compile the passed-in function, bailing out if it fails. (handler-case (setq function (compile nil function)) (error (c) (error (intl:gettext "Currently only compiled code can be stepped.~%~ Trying to compile the passed form resulted in ~ the following error:~% ~A") c)))) (let ((*print-length* *debug-print-length*) (*print-level* *debug-print-level*)) (format *debug-io* (intl:gettext "~2&Stepping the form~% ~S~%") form) (format *debug-io* (intl:gettext "~&using the debugger. Type HELP for help.~2%"))) (let* ((debug-function (di:function-debug-function function)) (bp (di:make-breakpoint #'main-hook-function debug-function :kind :function-start))) (di:activate-breakpoint bp) (push (create-breakpoint-info debug-function bp 0) *step-breakpoints*)) (funcall function)) ;;; STEP -- Public. ;;; (defmacro step (form) "STEP implements a debugging paradigm wherein the programmer is allowed to step through the evaluation of a form. We use the debugger's stepping facility to step through an anonymous function containing only form. Currently the stepping facility only supports stepping compiled code, so step will try to compile the resultant anonymous function. If this fails, e.g. because it closes over a non-null lexical environment, an error is signalled." `(step-internal #'(lambda () ,form) ',form)) ;;;; Backtrace: ;;; BACKTRACE -- Public. ;;; (defun backtrace (&optional (count most-positive-fixnum) (*standard-output* *debug-io*)) "Show a listing of the call stack going down from the current frame. In the debugger, the current frame is indicated by the prompt. Count is how many frames to show." (let ((*print-length* (or *debug-print-length* *print-length*)) (*print-level* (or *debug-print-level* *print-level*))) (fresh-line *standard-output*) (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame)) (di:frame-down frame)) (count count (1- count))) ((or (null frame) (zerop count))) (print-frame-call frame :number t)) (fresh-line *standard-output*) (values))) ;;;; Frame printing: (eval-when (compile eval) ;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal. ;;; ;;; This is a convenient way to express what to do for each type of lambda-list ;;; element. ;;; (defmacro lambda-list-element-dispatch (element &key required optional rest keyword deleted) `(etypecase ,element (di:debug-variable ,@required) (cons (ecase (car ,element) (:optional ,@optional) (:rest ,@rest) (:keyword ,@keyword))) (symbol (assert (eq ,element :deleted)) ,@deleted))) (defmacro lambda-var-dispatch (variable location deleted valid other) (let ((var (gensym))) `(let ((,var ,variable)) (cond ((eq ,var :deleted) ,deleted) ((eq (di:debug-variable-validity ,var ,location) :valid) ,valid) (t ,other))))) ) ;EVAL-WHEN ;;; This is used in constructing arg lists for debugger printing when the arg ;;; list is unavailable, some arg is unavailable or unused, etc. ;;; (defstruct (unprintable-object (:constructor make-unprintable-object (string)) (:print-function (lambda (x s d) (declare (ignore d)) (format s "#<~A>" (unprintable-object-string x))))) string) ;;; PRINT-FRAME-CALL-1 -- Internal. ;;; ;;; This prints frame with verbosity level 1. If we hit a rest-arg, ;;; then print as many of the values as possible, ;;; punting the loop over lambda-list variables since any other arguments ;;; will be in the rest-arg's list of values. ;;; (defun print-frame-call-1 (frame) (let* ((d-fun (di:frame-debug-function frame)) (loc (di:frame-code-location frame)) (results (list (di:debug-function-name d-fun)))) (handler-case (dolist (ele (di:debug-function-lambda-list d-fun)) (lambda-list-element-dispatch ele :required ((push (frame-call-arg ele loc frame) results)) :optional ((push (frame-call-arg (second ele) loc frame) results)) :keyword ((push (second ele) results) (push (frame-call-arg (third ele) loc frame) results)) :deleted ((push (frame-call-arg ele loc frame) results)) :rest ((lambda-var-dispatch (second ele) loc nil (progn (setf results (append (reverse (di:debug-variable-value (second ele) frame)) results)) (return)) (push (make-unprintable-object (intl:gettext "unavaliable-rest-arg")) results))))) (di:lambda-list-unavailable () (push (make-unprintable-object (intl:gettext "lambda-list-unavailable")) results))) (prin1 (mapcar #'ensure-printable-object (nreverse results))) (when (di:debug-function-kind d-fun) (write-char #\[) (prin1 (di:debug-function-kind d-fun)) (write-char #\])))) (defun ensure-printable-object (object) (handler-case (with-open-stream (out (make-broadcast-stream)) (prin1 object out) object) (error (cond) (declare (ignore cond)) (make-unprintable-object (format nil (intl:gettext "error printing object {~X}") (kernel:get-lisp-obj-address object)))))) (defun frame-call-arg (var location frame) (lambda-var-dispatch var location (make-unprintable-object (intl:gettext "unused-arg")) (di:debug-variable-value var frame) (make-unprintable-object (intl:gettext "unavailable-arg")))) ;;; PRINT-FRAME-CALL -- Interface ;;; ;;; This prints a representation of the function call causing frame to exist. ;;; Verbosity indicates the level of information to output; zero indicates just ;;; printing the debug-function's name, and one indicates displaying call-like, ;;; one-liner format with argument values. ;;; (defun print-frame-call (frame &key ((:print-length *print-length*) (or *debug-print-length* *print-length*)) ((:print-level *print-level*) (or *debug-print-level* *print-level*)) (verbosity *default-print-frame-call-verbosity*) (number nil)) (cond ((zerop verbosity) (when number (format t "~&~S: " (di:frame-number frame))) (format t "~S" frame)) (t (when number (format t "~&~S: " (di:frame-number frame))) (print-frame-call-1 frame))) (when (>= verbosity 2) (let ((loc (di:frame-code-location frame))) (handler-case (progn (di:code-location-debug-block loc) (format t (intl:gettext "~%Source: ")) (print-code-location-source-form loc 0)) (di:debug-condition (ignore) ignore) (error (cond) (format t (intl:gettext "Error finding source: ~A") cond)))))) ;;; SAFE-CONDITION-MESSAGE -- Internal ;;; ;;; Safely print condition to a string, handling any errors during ;;; printing. ;;; (defun safe-condition-message (condition) (handler-case (princ-to-string condition) (error (cond) ;; Beware of recursive errors in printing, so only use the condition ;; if it is printable itself: (format nil (intl:gettext "Unable to display error condition~@[: ~A~]") (ignore-errors (princ-to-string cond)))))) ;;;; Invoke-debugger. (defvar *debugger-hook* nil "This is either nil or a function of two arguments, a condition and the value of *debugger-hook*. This function can either handle the condition or return which causes the standard debugger to execute. The system passes the value of this variable to the function because it binds *debugger-hook* to nil around the invocation.") ;;; These are bound on each invocation of INVOKE-DEBUGGER. ;;; (defvar *debug-restarts*) (defvar *debug-condition*) ;;; INVOKE-TTY-DEBUGGER -- Internal ;;; ;;; Print condition and invoke the TTY debugger. ;;; (defun invoke-tty-debugger (condition) (format *error-output* (intl:gettext "~2&~A~% [Condition of type ~S]~2&") (safe-condition-message *debug-condition*) (type-of *debug-condition*)) (unless (typep condition 'step-condition) (show-restarts *debug-restarts* *error-output*)) (internal-debug)) ;;; REAL-INVOKE-DEBUGGER -- Internal ;;; ;;; This function really invokes the current standard debugger. ;;; This is overwritten by e.g. the Motif Interface code. It is a ;;; function and not a special variable hook, because users are ;;; supposed to use *debugger-hook*, and this is supposed to be the ;;; safe fall-back, which should be fairly secure against ;;; accidental mishaps. ;;; (defun real-invoke-debugger (condition) (invoke-tty-debugger condition)) ;;; INVOKE-DEBUGGER -- Public. ;;; (defun invoke-debugger (condition) "The CMU Common Lisp debugger. Type h for help." (when *debugger-hook* (let ((hook *debugger-hook*) (*debugger-hook* nil)) (funcall hook condition hook))) (unix:unix-sigsetmask 0) (let* ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) (*standard-input* *debug-io*) ;in case of setq (*standard-output* *debug-io*) ;'' '' '' '' (*error-output* *debug-io*) ;; Rebind some printer control variables. (kernel:*current-level* 0) (*print-readably* nil) (*read-eval* t) ;; XXX: Fixme: What external format do we really want to use ;; in the debugger? This is problem if we have a badly ;; formed string that the current external format can't ;; handle. #+unicode (*default-external-format* :iso8859-1)) (real-invoke-debugger condition))) ;;; SHOW-RESTARTS -- Internal. ;;; (defun show-restarts (restarts &optional (s *error-output*)) (when restarts (format s (intl:gettext "~&Restarts:~%")) (let ((count 0) (names-used '(nil)) (max-name-len 0)) (dolist (restart restarts) (let ((name (restart-name restart))) (when name (let ((len (length (princ-to-string name)))) (when (> len max-name-len) (setf max-name-len len)))))) (unless (zerop max-name-len) (incf max-name-len 3)) (dolist (restart restarts) (let ((name (restart-name restart))) (cond ((member name names-used) (format s "~& ~2D: ~@VT~A~%" count max-name-len restart)) (t (format s "~& ~2D: [~VA] ~A~%" count (- max-name-len 3) name restart) (push name names-used)))) (incf count))))) ;;; INTERNAL-DEBUG -- Internal Interface. ;;; ;;; This calls DEBUG-LOOP, performing some simple initializations before doing ;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger. ;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug ;;; prompt as quickly as possible with as little risk as possible for stepping ;;; on whatever is causing recursive errors. ;;; (defun internal-debug () (let ((*in-the-debugger* t) (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*) (format *debug-io* (intl:gettext "~2&Debug (type H for help)~2%"))) #-mp (debug-loop) #+mp (mp:without-scheduling (debug-loop)))) ;;;; Debug-loop. (defvar *flush-debug-errors* t "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger. The 'flush' command toggles this.") (defvar *debug-readtable* nil "When non-NIL, becomes the system *READTABLE* in the debugger read-eval-print loop") (defvar *debug-print-current-frame* t "When non-NIL, print the current frame when entering the debugger.") (defun maybe-handle-dead-input-stream (condition) ;; Scenario: "xon cmucl -edit" ;; Then close the display with the window manager or shutdown the ;; local computer. The remote lisp goes into infinite error loop. (labels ((real-stream (stream) ;; Using etypecase here causes an infloop in SLIME: ;; SLIME's slime-input-streams are not fd-streams (etypecase stream (system:fd-stream (values stream (system:fd-stream-fd stream))) (synonym-stream (real-stream (symbol-value (synonym-stream-symbol stream)))) (two-way-stream (real-stream (two-way-stream-input-stream stream)))))) (when (typep condition 'stream-error) (let* ((stream-with-error (stream-error-stream condition)) (real-stream-with-error (real-stream stream-with-error)) (real-debug-io (real-stream *debug-io*))) (when (and (eq real-stream-with-error real-debug-io) (not (unix:unix-isatty (system:fd-stream-fd real-debug-io)))) ;; Probably running on a remote processor and lost the connection. (ext:quit)))))) (defun debug-loop () (let* ((*debug-command-level* (1+ *debug-command-level*)) (*real-stack-top* (di:top-frame)) (*stack-top* (or *stack-top-hint* *real-stack-top*)) (*stack-top-hint* nil) (*current-frame* *stack-top*) (*readtable* (or *debug-readtable* *readtable*))) (handler-bind ((di:debug-condition #'(lambda (condition) (princ condition *debug-io*) (throw 'debug-loop-catcher nil)))) (when *debug-print-current-frame* (fresh-line) (print-frame-call *current-frame* :verbosity 2)) (loop (catch 'debug-loop-catcher (handler-bind ((error #'(lambda (condition) (maybe-handle-dead-input-stream condition) (when *flush-debug-errors* (clear-input *debug-io*) (princ condition) (format t (intl:gettext "~&Error flushed ...")) (throw 'debug-loop-catcher nil))))) ;; Must bind level for restart function created by ;; WITH-SIMPLE-RESTART. (let ((level *debug-command-level*) (restart-commands (make-restart-commands))) (with-simple-restart (abort (intl:gettext "Return to debug level ~D.") level) (funcall *debug-prompt*) (let ((input (ext:get-stream-command *debug-io*))) (cond (input (let ((cmd-fun (debug-command-p (ext:stream-command-name input) restart-commands))) (cond ((not cmd-fun) (error (intl:gettext "Unknown stream-command -- ~S.") input)) ((consp cmd-fun) (error (intl:gettext "Ambiguous debugger command: ~S.") cmd-fun)) (t (apply cmd-fun (ext:stream-command-args input)))))) (t (let* ((exp (read)) (cmd-fun (debug-command-p exp restart-commands))) (cond ((not cmd-fun) (debug-eval-print exp)) ((consp cmd-fun) (format t (intl:gettext "~&Your command, ~S, is ambiguous:~%") exp) (dolist (ele cmd-fun) (format t " ~A~%" ele))) (t (funcall cmd-fun))))))))))))))) (defvar *auto-eval-in-frame* t "When set (the default), evaluations in the debugger's command loop occur relative to the current frame's environment without the need of debugger forms that explicitly control this kind of evaluation.") (defun debug-eval-print (exp) (when (and (fboundp 'lisp::commandp) (funcall 'lisp::commandp exp)) (return-from debug-eval-print (funcall 'lisp::invoke-command-interactive exp))) (setq +++ ++ ++ + + - - exp) (let* ((values (multiple-value-list (if (and (fboundp 'compile) *auto-eval-in-frame*) (di:eval-in-frame *current-frame* -) (eval -)))) (*standard-output* *debug-io*)) (fresh-line) (if values (prin1 (car values))) (dolist (x (cdr values)) (fresh-line) (prin1 x)) (setq /// // // / / values) (setq *** ** ** * * (car values)) ;; Make sure nobody passes back an unbound marker. (unless (boundp '*) (setq * nil) (fresh-line) (princ (intl:gettext "Setting * to NIL -- was unbound marker."))))) ;;;; Debug loop functions. ;;; These commands are function, not really commands, so users can get their ;;; hands on the values returned. ;;; (eval-when (eval compile) (defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name (symbol (di:debug-function-symbol-variables (di:frame-debug-function *current-frame*) name)) (simple-string (di:ambiguous-debug-variables (di:frame-debug-function *current-frame*) name)))) (location (di:frame-code-location *current-frame*)) ;; Let's only deal with valid variables. (vars (remove-if-not #'(lambda (v) (eq (di:debug-variable-validity v location) :valid)) temp))) (declare (list vars)) (cond ((null vars) (error (intl:gettext "No known valid variables match ~S.") name)) ((= (length vars) 1) ,(ecase ref-or-set (:ref '(di:debug-variable-value (car vars) *current-frame*)) (:set `(setf (di:debug-variable-value (car vars) *current-frame*) ,value-var)))) (t ;; Since we have more than one, first see if we have any ;; variables that exactly match the specification. (let* ((name (etypecase name (symbol (symbol-name name)) (simple-string name))) (exact (remove-if-not #'(lambda (v) (string= (di:debug-variable-name v) name)) vars)) (vars (or exact vars))) (declare (simple-string name) (list exact vars)) (cond ;; Check now for only having one variable. ((= (length vars) 1) ,(ecase ref-or-set (:ref '(di:debug-variable-value (car vars) *current-frame*)) (:set `(setf (di:debug-variable-value (car vars) *current-frame*) ,value-var)))) ;; If there weren't any exact matches, flame about ambiguity ;; unless all the variables have the same name. ((and (not exact) (find-if-not #'(lambda (v) (string= (di:debug-variable-name v) (di:debug-variable-name (car vars)))) (cdr vars))) (error (intl:gettext "Specification ambiguous:~%~{ ~A~%~}") (mapcar #'di:debug-variable-name (delete-duplicates vars :test #'string= :key #'di:debug-variable-name)))) ;; All names are the same, so see if the user ID'ed one of them. (id-supplied (let ((v (find id vars :key #'di:debug-variable-id))) (unless v (error (intl:gettext "Invalid variable ID, ~D, should have been one of ~S.") id (mapcar #'di:debug-variable-id vars))) ,(ecase ref-or-set (:ref '(di:debug-variable-value v *current-frame*)) (:set `(setf (di:debug-variable-value v *current-frame*) ,value-var))))) (t (error (intl:gettext "Specify variable ID to disambiguate ~S. Use one of ~S.") name (mapcar #'di:debug-variable-id vars))))))))) ) ;EVAL-WHEN ;;; VAR -- Public. ;;; (defun var (name &optional (id 0 id-supplied)) "Returns a variable's value if possible. Name is a simple-string or symbol. If it is a simple-string, it is an initial substring of the variable's name. If name is a symbol, it has the same name and package as the variable whose value this function returns. If the symbol is uninterned, then the variable has the same name as the symbol, but it has no package. If name is the initial substring of variables with different names, then this return no values after displaying the ambiguous names. If name determines multiple variables with the same name, then you must use the optional id argument to specify which one you want. If you left id unspecified, then this returns no values after displaying the distinguishing id values. The result of this function is limited to the availability of variable information. This is SETF'able." (define-var-operation :ref)) ;;; (defun (setf var) (value name &optional (id 0 id-supplied)) (define-var-operation :set value)) ;;; ARG -- Public. ;;; (defun arg (n) "Returns the n'th argument's value if possible. Argument zero is the first argument in a frame's default printed representation. Count keyword/value pairs as separate arguments." (multiple-value-bind (var lambda-var-p) (nth-arg n (handler-case (di:debug-function-lambda-list (di:frame-debug-function *current-frame*)) (di:lambda-list-unavailable () (error (intl:gettext "No argument values are available."))))) (if lambda-var-p (lambda-var-dispatch var (di:frame-code-location *current-frame*) (error (intl:gettext "Unused arguments have no values.")) (di:debug-variable-value var *current-frame*) (error (intl:gettext "Invalid argument value."))) var))) ;;; NTH-ARG -- Internal. ;;; ;;; This returns the n'th arg as the user sees it from args, the result of ;;; DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential debug-variable ;;; from the lambda-list, then the second value is t. If this returns a ;;; keyword symbol or a value from a rest arg, then the second value is nil. ;;; (defun nth-arg (count args) (let ((n count)) (dolist (ele args (error (intl:gettext "Argument specification out of range -- ~S.") n)) (lambda-list-element-dispatch ele :required ((if (zerop n) (return (values ele t)))) :optional ((if (zerop n) (return (values (second ele) t)))) :keyword ((cond ((zerop n) (return (values (second ele) nil))) ((zerop (decf n)) (return (values (third ele) t))))) :deleted ((if (zerop n) (return (values ele t)))) :rest ((let ((var (second ele))) (lambda-var-dispatch var (di:frame-code-location *current-frame*) (error (intl:gettext "Unused rest-arg before n'th argument.")) (dolist (value (di:debug-variable-value var *current-frame*) (error (intl:gettext "Argument specification out of range -- ~S.") n)) (if (zerop n) (return-from nth-arg (values value nil)) (decf n))) (error (intl:gettext "Invalid rest-arg before n'th argument.")))))) (decf n)))) ;;;; Debug loop command definition: (defvar *debug-commands* nil) ;;; DEF-DEBUG-COMMAND -- Internal. ;;; ;;; Interface to *debug-commands*. No required arguments in args are ;;; permitted. ;;; (defmacro def-debug-command (name args &rest body) (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND")))) `(progn (when (assoc ,name *debug-commands* :test #'string=) (setf *debug-commands* (remove ,name *debug-commands* :key #'car :test #'string=))) (defun ,fun-name ,args (unless *in-the-debugger* (error (intl:gettext "Invoking debugger command while outside the debugger."))) ,@body) (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) ;;; DEF-DEBUG-COMMAND-ALIAS -- Internal. ;;; (defun def-debug-command-alias (new-name existing-name) (let ((pair (assoc existing-name *debug-commands* :test #'string=))) (unless pair (error (intl:gettext "Unknown debug command name -- ~S") existing-name)) (push (cons new-name (cdr pair)) *debug-commands*)) new-name) ;;; DEBUG-COMMAND-P -- Internal. ;;; ;;; This takes a symbol and uses its name to find a debugger command, using ;;; initial substring matching. It returns the command function if form ;;; identifies only one command, but if form is ambiguous, this returns a list ;;; of the command names. If there are no matches, this returns nil. Whenever ;;; the loop that looks for a set of possibilities encounters an exact name ;;; match, we return that command function immediately. ;;; (defun debug-command-p (form &optional other-commands) (if (or (symbolp form) (integerp form)) (let* ((name (if (symbolp form) (symbol-name form) (format nil "~d" form))) (len (length name)) (res nil)) (declare (simple-string name) (fixnum len) (list res)) ;; ;; Find matching commands, punting if exact match. (flet ((match-command (ele) (let* ((str (car ele)) (str-len (length str))) (declare (simple-string str) (fixnum str-len)) (cond ((< str-len len)) ((= str-len len) (when (string= name str :end1 len :end2 len) (return-from debug-command-p (cdr ele)))) ((string= name str :end1 len :end2 len) (push ele res)))))) (mapc #'match-command *debug-commands*) (mapc #'match-command other-commands)) ;; ;; Return the right value. (cond ((not res) nil) ((= (length res) 1) (cdar res)) (t ;Just return the names. (do ((cmds res (cdr cmds))) ((not cmds) res) (setf (car cmds) (caar cmds)))))))) ;;; ;;; Returns a list of debug commands (in the same format as *debug-commands*) ;;; that invoke each active restart. ;;; ;;; Two commands are made for each restart: one for the number, and one for ;;; the restart name (unless it's been shadowed by an earlier restart of the ;;; same name, or it is nil). ;;; (defun make-restart-commands (&optional (restarts *debug-restarts*)) (let ((commands) (num 0)) ; better be the same as show-restarts! (dolist (restart restarts) (let ((name (string (restart-name restart)))) ;; ;; Use %Invoke-Restart-Interactively because the dynamic ;; environment when the debugger invokes the restart can be ;; different from the dynamic environment when the debugger ;; computes active restarts. If this is the case, ;; Invoke-Restart-Interactively might find that the restart ;; being invoked is not currently active and signal a ;; Control-Error. (let ((restart-fun (lambda () (conditions::%invoke-restart-interactively restart)))) (push (cons (format nil "~d" num) restart-fun) commands) (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) (push (cons name restart-fun) commands)))) (incf num)) commands)) ;;; ;;; Frame changing commands. ;;; (def-debug-command "UP" () (let ((next (di:frame-up *current-frame*))) (cond (next (setf *current-frame* next) (print-frame-call next)) (t (format t (intl:gettext "~&Top of stack.")))))) (def-debug-command "DOWN" () (let ((next (di:frame-down *current-frame*))) (cond (next (setf *current-frame* next) (print-frame-call next)) (t (format t (intl:gettext "~&Bottom of stack.")))))) (def-debug-command-alias "D" "DOWN") (def-debug-command "TOP" () (do ((prev *current-frame* lead) (lead (di:frame-up *current-frame*) (di:frame-up lead))) ((null lead) (setf *current-frame* prev) (print-frame-call prev)))) (def-debug-command "BOTTOM" () (do ((prev *current-frame* lead) (lead (di:frame-down *current-frame*) (di:frame-down lead))) ((null lead) (setf *current-frame* prev) (print-frame-call prev)))) (def-debug-command-alias "B" "BOTTOM") (def-debug-command "FRAME" (&optional (n (read-prompting-maybe (intl:gettext "Frame number: ")))) (let ((current (di:frame-number *current-frame*))) (cond ((= n current) (princ (intl:gettext "You are here."))) ((> n current) (print-frame-call (setf *current-frame* (do ((prev *current-frame* lead) (lead (di:frame-down *current-frame*) (di:frame-down lead))) ((null lead) (princ (intl:gettext "Bottom of stack encountered.")) prev) (when (= n (di:frame-number prev)) (return prev)))))) (t (print-frame-call (setf *current-frame* (do ((prev *current-frame* lead) (lead (di:frame-up *current-frame*) (di:frame-up lead))) ((null lead) (princ (intl:gettext "Top of stack encountered.")) prev) (when (= n (di:frame-number prev)) (return prev))))))))) (def-debug-command-alias "F" "FRAME") ;; debug-return, equivalent to return-from-frame in some other lisps, ;; allows us to return an arbitrary value from any frame (def-debug-command "DEBUG-RETURN" (&optional (return (read-prompting-maybe (intl:gettext "debug-return: ")))) (unless (di:return-from-frame *current-frame* return) ;; the "unless" here is for aesthetical purposes only. If all goes ;; well with return-from-frame, the code after it will never get ;; reached anyway. (format t (intl:gettext "~@")))) (def-debug-command-alias "R" "DEBUG-RETURN") ;;; ;;; In and Out commands. ;;; (def-debug-command "QUIT" () (throw 'lisp::top-level-catcher nil)) (def-debug-command "GO" () (continue *debug-condition*) (error (intl:gettext "No restart named continue."))) (def-debug-command "RESTART" () (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts*) (write-string (intl:gettext "Restart: ")) (force-output) (setf num (read *standard-input*))) (let ((restart (typecase num (unsigned-byte (nth num *debug-restarts*)) (symbol (find num *debug-restarts* :key #'restart-name :test #'(lambda (sym1 sym2) (string= (symbol-name sym1) (symbol-name sym2))))) (t (format t (intl:gettext "~S is invalid as a restart name.~%") num) (return-from restart-debug-command nil))))) (if restart (invoke-restart-interactively restart) (princ (intl:gettext "No such restart.")))))) ;;; ;;; Information commands. ;;; (defvar *help-line-scroll-count* 20 "This controls how many lines the debugger's help command prints before printing a prompting line to continue with output.") (def-debug-command "HELP" () (let* ((translated (intl:dgettext "cmucl" debug-help-string)) (end -1) (len (length translated)) (len-1 (1- len))) (loop (let ((start (1+ end)) (count *help-line-scroll-count*)) (loop (setf end (position #\newline translated :start (1+ end))) (cond ((or (not end) (= end len-1)) (setf end len) (return)) ((or (zerop (decf count)) (= end len)) (return)))) (write-string translated *standard-output* :start start :end end)) (when (= end len) (return)) (format t (intl:gettext "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ")) (force-output) (let ((res (read-line))) (when (or (string= res "q") (string= res "Q")) (return)))))) (def-debug-command-alias "?" "HELP") (def-debug-command "ERROR" () (format t "~A~%" (safe-condition-message *debug-condition*)) (show-restarts *debug-restarts*)) (def-debug-command "BACKTRACE" () (backtrace (read-if-available most-positive-fixnum))) (def-debug-command "PRINT" () (print-frame-call *current-frame*)) (def-debug-command-alias "P" "PRINT") (def-debug-command "VPRINT" () (print-frame-call *current-frame* :print-level nil :print-length nil :verbosity (read-if-available 2))) (def-debug-command-alias "PP" "VPRINT") (def-debug-command "LIST-LOCALS" () (let ((d-fun (di:frame-debug-function *current-frame*))) (if (di:debug-variable-info-available d-fun) (let ((*print-level* (or *debug-print-level* *print-level*)) (*print-length* (or *debug-print-length* *print-length*)) (*standard-output* *debug-io*) (location (di:frame-code-location *current-frame*)) (prefix (read-if-available nil)) (any-p nil) (any-valid-p nil)) (dolist (v (di:ambiguous-debug-variables d-fun (if prefix (string prefix) ""))) (setf any-p t) (when (eq (di:debug-variable-validity v location) :valid) (setf any-valid-p t) (format t "~S~:[#~D~;~*~] = ~S~%" (di:debug-variable-symbol v) (zerop (di:debug-variable-id v)) (di:debug-variable-id v) (di:debug-variable-value v *current-frame*)))) (cond ((not any-p) (format t (intl:gettext "No local variables ~@[starting with ~A ~]~ in function.") prefix)) ((not any-valid-p) (format t (intl:gettext "All variables ~@[starting with ~A ~]currently ~ have invalid values.") prefix)))) (write-line (intl:gettext "No variable information available."))))) (def-debug-command-alias "L" "LIST-LOCALS") (def-debug-command "SOURCE" () (fresh-line) (print-code-location-source-form (di:frame-code-location *current-frame*) (read-if-available 0))) (def-debug-command "VSOURCE" () (fresh-line) (print-code-location-source-form (di:frame-code-location *current-frame*) (read-if-available 0) t)) ;;;; Source location printing: ;;; We cache a stream to the last valid file debug source so that we won't have ;;; to repeatedly open the file. ;;; (defvar *cached-debug-source* nil) (declaim (type (or di:debug-source null) *cached-debug-source*)) (defvar *cached-source-stream* nil) (declaim (type (or stream null) *cached-source-stream*)) ;;; To suppress the read-time evaluation #. macro during source read ;;; the *readtable* is modified. The *readtable* is cached to avoid ;;; copying it each time, and invalidated when the ;;; *cached-debug-source* has changed. (defvar *cached-readtable* nil) (declaim (type (or readtable null) *cached-readtable*)) (pushnew #'(lambda () (setq *cached-debug-source* nil *cached-source-stream* nil *cached-readtable* nil)) ext:*before-save-initializations*) ;;; We also cache the last top-level form that we printed a source for so that ;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS. ;;; (defvar *cached-top-level-form-offset* nil) (declaim (type (or kernel:index null) *cached-top-level-form-offset*)) (defvar *cached-top-level-form*) (defvar *cached-form-number-translations*) ;;; GET-TOP-LEVEL-FORM -- Internal ;;; ;;; Given a code location, return the associated form-number translations ;;; and the actual top-level form. We check our cache --- if there is a miss, ;;; we dispatch on the kind of the debug source. ;;; (defun get-top-level-form (location) (let ((d-source (di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) (eql (di:code-location-top-level-form-offset location) *cached-top-level-form-offset*)) (values *cached-form-number-translations* *cached-top-level-form*) (let* ((offset (di:code-location-top-level-form-offset location)) (res (ecase (di:debug-source-from d-source) (:file (get-file-top-level-form location)) ((:lisp :stream) (svref (di:debug-source-name d-source) offset))))) (setq *cached-top-level-form-offset* offset) (values (setq *cached-form-number-translations* (di:form-number-translations res offset)) (setq *cached-top-level-form* res)))))) ;;; GET-FILE-TOP-LEVEL-FORM -- Internal. ;;; ;;; Locates the source file (if it still exists) and grabs the top-level form. ;;; If the file is modified, we use the top-level-form offset instead of the ;;; recorded character offset. ;;; (defun get-file-top-level-form (location) (let* ((d-source (di:code-location-debug-source location)) (tlf-offset (di:code-location-top-level-form-offset location)) (local-tlf-offset (- tlf-offset (di:debug-source-root-number d-source))) (char-offset (aref (or (di:debug-source-start-positions d-source) (error (intl:gettext "No start positions map."))) local-tlf-offset)) (name (di:debug-source-name d-source)) ;; See ticket:70. Bind *d-p-d* to a unix host so we can ;; parse logical pathnames and search-lists that might be ;; stored in the source name. There is an issue if the name ;; is a logical pathname and the host isn't defined. This ;; will be interpreted as a search-list (undefined), but we ;; won't error out. This will be a problem if we try to ;; define the logical host with the same name later. (*default-pathname-defaults* (make-pathname :host lisp::*unix-host*))) (unless (eq d-source *cached-debug-source*) (unless (and *cached-source-stream* (equal (pathname *cached-source-stream*) (pathname name))) (setq *cached-readtable* nil) (when *cached-source-stream* (close *cached-source-stream*)) (setq *cached-source-stream* (open name :if-does-not-exist nil :external-format (c::debug-source-info d-source))) (unless *cached-source-stream* (error (intl:gettext "Source file no longer exists:~% ~A.") (namestring name))) (format t (intl:gettext "~%; File: ~A~%") (namestring name))) (setq *cached-debug-source* (if (= (di:debug-source-created d-source) (file-write-date name)) d-source nil))) (cond ((eq *cached-debug-source* d-source) (file-position *cached-source-stream* char-offset)) (t (format t (intl:gettext "~%; File has been modified since compilation:~%; ~A~@ ; Using form offset instead of character position.~%") (namestring name)) (file-position *cached-source-stream* 0) (let ((*read-suppress* t)) (dotimes (i local-tlf-offset) (read *cached-source-stream*))))) (unless *cached-readtable* (setq *cached-readtable* (copy-readtable)) (set-dispatch-macro-character #\# #\. #'(lambda (stream sub-char &rest rest) (declare (ignore rest sub-char)) (let ((token (read stream t nil t))) (format nil "#.~s" token))) *cached-readtable*)) (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) ;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal. ;;; (defun print-code-location-source-form (location context &optional verbose) (let* ((location (maybe-block-start-location location)) (*print-level* (if verbose nil (or *debug-print-level* *print-level*))) (*print-length* (if verbose nil (or *debug-print-length* *print-length*))) (form-num (di:code-location-form-number location))) (multiple-value-bind (translations form) (get-top-level-form location) (unless (< form-num (length translations)) (error (intl:gettext "Source path no longer exists."))) (prin1 (di:source-path-context form (svref translations form-num) context))))) ;;; ;;; Breakpoint and step commands. ;;; ;;; Steps to the next code-location (def-debug-command "STEP" () (setf *number-of-steps* (read-if-available 1)) (set-step-breakpoint *current-frame*) (continue *debug-condition*) (error (intl:gettext "Couldn't continue."))) ;;; Lists possible breakpoint locations, which are active, and where go will ;;; continue. Sets *possible-breakpoints* to the code-locations which can then ;;; be used by sbreakpoint. Takes a function as an optional argument. (def-debug-command "LIST-LOCATIONS" () (let ((df (read-if-available *default-breakpoint-debug-function*))) (cond ((consp df) (setf df (di:function-debug-function (eval df))) (setf *default-breakpoint-debug-function* df)) ((or (eq ':c df) (not *default-breakpoint-debug-function*)) (setf df (di:frame-debug-function *current-frame*)) (setf *default-breakpoint-debug-function* df))) (setf *possible-breakpoints* (possible-breakpoints df))) (let ((continue-at (di:frame-code-location *current-frame*))) (let ((active (location-in-list *default-breakpoint-debug-function* *breakpoints* :function-start)) (here (di:code-location= (di:debug-function-start-location *default-breakpoint-debug-function*) continue-at))) (when (or active here) (format t (intl:gettext "::FUNCTION-START ")) (when active (format t (intl:gettext " *Active*"))) (when here (format t (intl:gettext " *Continue here*"))))) (let ((prev-location nil) (prev-num 0) (this-num 0)) (flet ((flush () (when prev-location (let ((this-num (1- this-num))) (if (= prev-num this-num) (format t "~&~D: " prev-num) (format t "~&~D-~D: " prev-num this-num))) (print-code-location-source-form prev-location 0) (when *print-location-kind* (format t "~S " (di:code-location-kind prev-location))) (when (location-in-list prev-location *breakpoints*) (format t (intl:gettext " *Active*"))) (when (di:code-location= prev-location continue-at) (format t (intl:gettext " *Continue here*")))))) (dolist (code-location *possible-breakpoints*) (when (or *print-location-kind* (location-in-list code-location *breakpoints*) (di:code-location= code-location continue-at) (not prev-location) (not (eq (di:code-location-debug-source code-location) (di:code-location-debug-source prev-location))) (not (eq (di:code-location-top-level-form-offset code-location) (di:code-location-top-level-form-offset prev-location))) (not (eq (di:code-location-form-number code-location) (di:code-location-form-number prev-location)))) (flush) (setq prev-location code-location prev-num this-num)) (incf this-num)))) (when (location-in-list *default-breakpoint-debug-function* *breakpoints* :function-end) (format t (intl:gettext "~&::FUNCTION-END *Active* "))))) (def-debug-command-alias "LL" "LIST-LOCATIONS") ;;; set breakpoint at # given (def-debug-command "BREAKPOINT" () (let ((index (read-prompting-maybe (intl:gettext "Location number, :start, or :end: "))) (break t) (condition t) (print nil) (print-functions nil) (function nil) (bp) (place *default-breakpoint-debug-function*)) (flet ((get-command-line () (let ((command-line nil) (unique '(nil))) (loop (let ((next-input (read-if-available unique))) (when (eq next-input unique) (return)) (push next-input command-line))) (nreverse command-line))) (set-vars-from-command-line (command-line) (do ((arg (pop command-line) (pop command-line))) ((not arg)) (ecase arg (:condition (setf condition (pop command-line))) (:print (push (pop command-line) print)) (:break (setf break (pop command-line))) (:function (setf function (eval (pop command-line))) (setf *default-breakpoint-debug-function* (di:function-debug-function function)) (setf place *default-breakpoint-debug-function*) (setf *possible-breakpoints* (possible-breakpoints *default-breakpoint-debug-function*)))))) (setup-function-start () (let ((code-loc (di:debug-function-start-location place))) (setf bp (di:make-breakpoint #'main-hook-function place :kind :function-start)) (setf break (di:preprocess-for-eval break code-loc)) (setf condition (di:preprocess-for-eval condition code-loc)) (dolist (form print) (push (cons (di:preprocess-for-eval form code-loc) form) print-functions)))) (setup-function-end () (setf bp (di:make-breakpoint #'main-hook-function place :kind :function-end)) (setf break (coerce `(lambda (dummy) (declare (ignore dummy)) ,break) 'function)) (setf condition (coerce `(lambda (dummy) (declare (ignore dummy)) ,condition) 'function)) (dolist (form print) (push (cons (coerce `(lambda (dummy) (declare (ignore dummy)) ,form) 'function) form) print-functions))) (setup-code-location () (setf place (nth index *possible-breakpoints*)) (setf bp (di:make-breakpoint #'main-hook-function place :kind :code-location)) (dolist (form print) (push (cons (di:preprocess-for-eval form place) form) print-functions)) (setf break (di:preprocess-for-eval break place)) (setf condition (di:preprocess-for-eval condition place)))) (set-vars-from-command-line (get-command-line)) (cond ((or (eq index :start) (eq index :s)) (setup-function-start)) ((or (eq index :end) (eq index :e)) (setup-function-end)) (t (setup-code-location))) (di:activate-breakpoint bp) (let* ((new-bp-info (create-breakpoint-info place bp index :break break :print print-functions :condition condition)) (old-bp-info (location-in-list new-bp-info *breakpoints*))) (when old-bp-info (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info)) (setf *breakpoints* (remove old-bp-info *breakpoints*)) (format t (intl:gettext "Note: previous breakpoint removed.~%"))) (push new-bp-info *breakpoints*)) (print-breakpoint-info (first *breakpoints*)) (format t (intl:gettext "~&Added."))))) (def-debug-command-alias "BP" "BREAKPOINT") ;;; list all breakpoints set (def-debug-command "LIST-BREAKPOINTS" () (setf *breakpoints* (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) (dolist (info *breakpoints*) (print-breakpoint-info info))) (def-debug-command-alias "LB" "LIST-BREAKPOINTS") (def-debug-command-alias "LBP" "LIST-BREAKPOINTS") ;;; remove breakpoint n or all if none given (def-debug-command "DELETE-BREAKPOINT" () (let* ((index (read-if-available nil)) (bp-info (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) (cond (bp-info (di:delete-breakpoint (breakpoint-info-breakpoint bp-info)) (setf *breakpoints* (remove bp-info *breakpoints*)) (format t (intl:gettext "Breakpoint ~S removed.~%") index)) (index (format t (intl:gettext "Breakpoint doesn't exist."))) (t (dolist (ele *breakpoints*) (di:delete-breakpoint (breakpoint-info-breakpoint ele))) (setf *breakpoints* nil) (format t (intl:gettext "All breakpoints deleted.~%")))))) (def-debug-command-alias "DBP" "DELETE-BREAKPOINT") ;;; ;;; Miscellaneous commands. ;;; (def-debug-command "FLUSH-ERRORS" () (if (setf *flush-debug-errors* (not *flush-debug-errors*)) (write-line (intl:gettext "Errors now flushed.")) (write-line (intl:gettext "Errors now create nested debug levels.")))) (def-debug-command "DESCRIBE" () (let* ((curloc (di:frame-code-location *current-frame*)) (debug-fun (di:code-location-debug-function curloc)) (function (di:debug-function-function debug-fun))) (if function (describe function) (format t (intl:gettext "Can't figure out the function for this frame."))))) ;;; ;;; Editor commands. ;;; (def-debug-command "EDIT-SOURCE" () (unless (ed::ts-stream-p *terminal-io*) (error (intl:gettext "The debugger's EDIT-SOURCE command only works in slave Lisps ~ connected to a Hemlock editor."))) (let* ((wire (ed::ts-stream-wire *terminal-io*)) (location (maybe-block-start-location (di:frame-code-location *current-frame*))) (d-source (di:code-location-debug-source location)) (name (di:debug-source-name d-source))) (ecase (di:debug-source-from d-source) (:file (let* ((tlf-offset (di:code-location-top-level-form-offset location)) (local-tlf-offset (- tlf-offset (di:debug-source-root-number d-source))) (char-offset (aref (or (di:debug-source-start-positions d-source) (error (intl:gettext "No start positions map."))) local-tlf-offset))) (wire:remote wire (ed::edit-source-location (namestring name) (di:debug-source-created d-source) tlf-offset local-tlf-offset char-offset (di:code-location-form-number location))) (wire:wire-force-output wire))) ((:lisp :stream) (wire:remote wire (ed::cannot-edit-source-location)) (wire:wire-force-output wire))))) ;;;; Debug loop command utilities. (defun read-prompting-maybe (prompt &optional (in *standard-input*) (out *standard-output*)) (unless (ext:listen-skip-whitespace in) (princ prompt out) (force-output out)) (read in)) (defun read-if-available (default &optional (stream *standard-input*)) (if (ext:listen-skip-whitespace stream) (read stream) default)) cmucl-21a/src/code/defmacro.lisp000066400000000000000000000445131260377556400167420ustar00rootroot00000000000000;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/defmacro.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Written by Blaine Burks. ;;; (in-package "LISP") (intl:textdomain "cmucl") ;;;; Some variable definitions. ;;; Variables for amassing the results of parsing a defmacro. Declarations ;;; in DEFMACRO are the reason this isn't as easy as it sounds. ;;; (defvar *arg-tests* () "A list of tests that do argument counting at expansion time.") (defvar *system-lets* () "Let bindings that are done to make lambda-list parsing possible.") (defvar *user-lets* () "Let bindings that the user has explicitly supplied.") (defvar *default-default* nil "Unsupplied optional and keyword arguments get this value defaultly.") ;; Temps that we introduce and might not reference. (defvar *ignorable-vars*) ;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE. ;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare ;;; form to put where this code is inserted, and the documentation for the ;;; parsed body. ;;; (defun parse-defmacro (lambda-list arg-list-name code name error-kind &key (annonymousp nil) (doc-string-allowed t) ((:environment env-arg-name)) ((:default-default *default-default*)) (error-fun 'error)) "Returns as multiple-values a parsed body, any local-declarations that should be made where this body is inserted, and a doc-string if there is one." (multiple-value-bind (body declarations documentation) (parse-body code nil doc-string-allowed) (let* ((*arg-tests* ()) (*user-lets* ()) (*system-lets* ()) (*ignorable-vars* ())) (multiple-value-bind (env-arg-used minimum maximum) (parse-defmacro-lambda-list lambda-list arg-list-name name error-kind error-fun (not annonymousp) nil env-arg-name) (values `(let* ,(nreverse *system-lets*) ,@(when *ignorable-vars* `((declare (ignorable ,@*ignorable-vars*)))) ,@*arg-tests* (let* ,(nreverse *user-lets*) ,@declarations ,@body)) `(,@(when (and env-arg-name (not env-arg-used)) `((declare (ignore ,env-arg-name))))) documentation minimum maximum))))) (defun restify-dotted-lambda-list (lambda-list) (collect ((new)) (do ((tail lambda-list (cdr tail))) ((atom tail) (progn (unless (null tail) (new '&rest tail)) (new))) (new (car tail))))) #+nil (declaim (inline dotted-list-length)) ;;; FIXME: Remove this later! This was left here to make ;;; bootstrapping list-length-bounded-p easier. (defun dotted-list-length (list) ;; this is a workaround for spurious efficiency notes when compiling ;; DEFTYPE declarations in code under high optimization (declare (optimize (ext:inhibit-warnings 3))) (loop for tail on list until (atom tail) count t)) (declaim (inline list-length-bounded-p)) (defun list-length-bounded-p (list min &optional max) ;; this is a workaround for spurious efficiency notes when compiling ;; DEFTYPE declarations in code under high optimization (declare (optimize (ext:inhibit-warnings 3))) (let ((limit (if max max min))) (do ((tail list (cdr tail)) (count 0 (1+ count))) ((or (atom tail) (>= count limit)) ;; If MAX was given, we better be at end of list and have ;; length at least MIN. Otherwise, we just need to make sure ;; the length is at least MIN. (if max (and (atom tail) (<= min count)) (<= min count)))))) (defun parse-defmacro-lambda-list (lambda-list arg-list-name name error-kind error-fun &optional top-level env-illegal env-arg-name) (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) (lambda-list (restify-dotted-lambda-list lambda-list)) (now-processing :required) (maximum 0) (minimum 0) (keys ()) (key-seen nil) rest-name restp allow-other-keys-p env-arg-used) (when (and (member '&whole lambda-list) (not (eq (car lambda-list) '&whole))) (simple-program-error (intl:gettext "&Whole must appear first in ~S lambda-list.") error-kind)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((null rest-of-args)) (let ((var (car rest-of-args))) (cond ((eq var '&whole) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) ;; For compiler macros, we have to do something ;; special in case the form has a car eq to ;; funcall, as specified in the CLHS. In this ;; case, we skip over the funcall and pretend ;; that the rest of the form is the actual form. ;; ;; This is a gross hack because we look at ;; error-kind to figure out if we're defining a ;; compiler macro or not. (when (eq error-kind 'define-compiler-macro) (push-let-binding arg-list-name arg-list-name t `(progn (not (and (listp ,arg-list-name) (eq 'funcall (car ,arg-list-name))))) `(progn (setf ,arg-list-name ;; Handle the case (funcall #'foo args) (if (consp (second ,arg-list-name)) (list* (second (second ,arg-list-name)) (cddr ,arg-list-name)) (cdr ,arg-list-name)))))) (push-let-binding (car rest-of-args) arg-list-name nil)) ((and (cdr rest-of-args) (consp (cadr rest-of-args))) (pop rest-of-args) (let* ((destructuring-lambda-list (car rest-of-args)) (sub (gensym "WHOLE-SUBLIST"))) (push-sub-list-binding sub arg-list-name destructuring-lambda-list name error-kind error-fun) (parse-defmacro-lambda-list destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error "&WHOLE" error-kind name)))) ((eq var '&environment) (cond (env-illegal (simple-program-error (intl:gettext "&environment not valid with ~S.") error-kind)) ((not top-level) (simple-program-error (intl:gettext "&environment only valid at top level of lambda-list.")))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (append-let-binding (car rest-of-args) env-arg-name nil) (setf env-arg-used t)) (t (defmacro-error "&ENVIRONMENT" error-kind name)))) ;; ;; This branch implements an extension to Common Lisp ;; that was formerly implemented for &body. In place of ;; a symbol following &body, there could be a list of up ;; to three elements which will be bound to the body, ;; declarations, and doc-string of the body. ((eq var '&parse-body) (unless (and (cdr rest-of-args) (consp (cadr rest-of-args)) (symbolp (caadr rest-of-args))) (simple-program-error (intl:gettext "Invalid ~a") '&parse-body)) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (let ((body-name (caar rest-of-args)) (declarations-name (cadar rest-of-args)) (doc-string-name (caddar rest-of-args)) (parse-body-values (gensym))) (push-let-binding parse-body-values `(multiple-value-list (parse-body ,path ,env-arg-name ,(not (null doc-string-name)))) t) (setf env-arg-used t) (when body-name (push-let-binding body-name `(car ,parse-body-values) nil)) (when declarations-name (push-let-binding declarations-name `(cadr ,parse-body-values) nil)) (when doc-string-name (push-let-binding doc-string-name `(caddr ,parse-body-values) nil)))) ;; ((member var '(&rest &body)) (cond ((and (cddr rest-of-args) (not (member (caddr rest-of-args) lambda-list-keywords))) (defmacro-error (symbol-name var) error-kind name)) ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (push-let-binding (car rest-of-args) path nil)) ((and (cdr rest-of-args) (consp (cadr rest-of-args))) (pop rest-of-args) (setq restp t) (let* ((destructuring-lambda-list (car rest-of-args)) (sub (gensym "REST-SUBLIST"))) (push-sub-list-binding sub path destructuring-lambda-list name error-kind error-fun) (parse-defmacro-lambda-list destructuring-lambda-list sub name error-kind error-fun))) (t (defmacro-error (symbol-name var) error-kind name)))) ((eq var '&optional) (setf now-processing :optionals)) ((eq var '&key) (setf now-processing :keywords) (setf rest-name (gensym "KEYWORDS-")) (push rest-name *ignorable-vars*) (setf restp t) (setq key-seen t) (push-let-binding rest-name path t)) ((eq var '&allow-other-keys) (setf allow-other-keys-p t)) ((eq var '&aux) (setf now-processing :auxs)) ((listp var) (case now-processing (:required (let ((sub-list-name (gensym "SUBLIST-"))) (push-sub-list-binding sub-list-name `(car ,path) var name error-kind error-fun) (parse-defmacro-lambda-list var sub-list-name name error-kind error-fun)) (setf path `(cdr ,path)) (incf minimum) (incf maximum)) (:optionals (when (> (length var) 3) (cerror (intl:gettext "Ignore extra noise.") (intl:gettext "More than variable, initform, and suppliedp ~ in &optional binding - ~S") var)) (push-optional-binding (car var) (cadr var) (caddr var) `(not (null ,path)) `(car ,path) name error-kind error-fun) (setf path `(cdr ,path)) (incf maximum)) (:keywords (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) (car var))) (keyword (if keyword-given (caar var) (make-keyword variable))) (supplied-p (caddr var))) (push-optional-binding variable (cadr var) supplied-p `(keyword-supplied-p ',keyword ,rest-name) `(lookup-keyword ',keyword ,rest-name) name error-kind error-fun) (push keyword keys))) (:auxs (push-let-binding (car var) (cadr var) nil)))) ((symbolp var) (case now-processing (:required (incf minimum) (incf maximum) (push-let-binding var `(car ,path) nil) (setf path `(cdr ,path))) (:optionals (incf maximum) (push-let-binding var `(car ,path) nil `(not (null ,path))) (setf path `(cdr ,path))) (:keywords (let ((key (make-keyword var))) ;; For deftype, the default value for a keyword is ;; '*, not NIL. This hack uses ERROR-KIND to ;; figure out if we're defining a new type or not. (push-let-binding var (if (eq error-kind 'deftype) `(or (lookup-keyword ,key ,rest-name) ,*default-default*) `(lookup-keyword ,key ,rest-name)) nil) (push key keys))) (:auxs (push-let-binding var nil nil)))) (t (simple-program-error (intl:gettext "Non-symbol in lambda-list - ~S.") var))))) (push `(unless (list-length-bounded-p (the list ,(if top-level `(cdr ,arg-list-name) arg-list-name)) ,minimum ,@(unless restp (list maximum))) ,(let ((arg (if top-level `(cdr ,arg-list-name) arg-list-name))) (if (eq error-fun 'error) `(do-arg-count-error ',error-kind ',name ,arg ',lambda-list ,minimum ,(unless restp maximum)) `(,error-fun 'defmacro-ll-arg-count-error :kind ',error-kind ,@(when name `(:name ',name)) :argument ,arg :lambda-list ',lambda-list :minimum ,minimum ,@(unless restp `(:maximum ,maximum)))))) *arg-tests*) (when key-seen (let ((problem (gensym "KEY-PROBLEM-")) (info (gensym "INFO-"))) (push `(multiple-value-bind (,problem ,info) (verify-keywords ,rest-name ',keys ',allow-other-keys-p) (when ,problem (,error-fun 'defmacro-ll-broken-key-list-error :kind ',error-kind ,@(when name `(:name ',name)) :problem ,problem :info ,info))) *arg-tests*))) (values env-arg-used minimum (if (null restp) maximum nil)))) ;;; We save space in macro definitions by callig this function. ;;; (defun do-arg-count-error (error-kind name arg lambda-list minimum maximum) (multiple-value-bind (fname debug:*stack-top-hint*) (kernel:find-caller-name) (error 'defmacro-ll-arg-count-error :kind error-kind :function-name fname :name name :argument arg :lambda-list lambda-list :minimum minimum :maximum maximum))) (defun push-sub-list-binding (variable path object name error-kind error-fun) (let ((var (gensym "TEMP-"))) (push `(,variable (let ((,var ,path)) (if (listp ,var) ,var (,error-fun 'defmacro-bogus-sublist-error :kind ',error-kind ,@(when name `(:name ',name)) :object ,var :lambda-list ',object)))) *system-lets*))) (defun push-let-binding (variable path systemp &optional condition (init-form *default-default*)) (let ((let-form (if condition `(,variable (if ,condition ,path ,init-form)) `(,variable ,path)))) (if systemp (push let-form *system-lets*) (push let-form *user-lets*)))) (defun append-let-binding (variable path systemp &optional condition (init-form *default-default*)) (let ((let-form (if condition `(,variable (if ,condition ,path ,init-form)) `(,variable ,path)))) (if systemp (setq *system-lets* (nconc *system-lets* (list let-form))) (setq *user-lets* (nconc *user-lets* (list let-form)))))) (defun push-optional-binding (value-var init-form supplied-var condition path name error-kind error-fun) (unless supplied-var (setf supplied-var (gensym "SUPPLIEDP-"))) (push-let-binding supplied-var condition t) (cond ((consp value-var) (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) (push-sub-list-binding whole-thing `(if ,supplied-var ,path ,init-form) value-var name error-kind error-fun) (parse-defmacro-lambda-list value-var whole-thing name error-kind error-fun))) ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t (simple-program-error (intl:gettext "Illegal optional variable name: ~S") value-var)))) (defun make-keyword (symbol) "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." (intern (symbol-name symbol) *keyword-package*)) (defun defmacro-error (problem kind name) (simple-program-error (intl:gettext "Illegal or ill-formed ~A argument in ~A~@[ ~S~].") problem kind name)) ;;;; Conditions signaled at runtime by the resultant body. (define-condition defmacro-lambda-list-bind-error (program-error) ((kind :reader defmacro-lambda-list-bind-error-kind :initarg :kind) (name :reader defmacro-lambda-list-bind-error-name :initarg :name :initform nil))) (defun print-defmacro-ll-bind-error-intro (condition stream) (if (null (defmacro-lambda-list-bind-error-name condition)) (format stream (intl:gettext "Error while parsing arguments to ~A in ~S:~%") (defmacro-lambda-list-bind-error-kind condition) (condition-function-name condition)) (format stream (intl:gettext "Error while parsing arguments to ~A ~S:~%") (defmacro-lambda-list-bind-error-kind condition) (defmacro-lambda-list-bind-error-name condition)))) (define-condition defmacro-bogus-sublist-error (defmacro-lambda-list-bind-error) ((object :reader defmacro-bogus-sublist-error-object :initarg :object) (lambda-list :reader defmacro-bogus-sublist-error-lambda-list :initarg :lambda-list)) (:report (lambda (condition stream) (print-defmacro-ll-bind-error-intro condition stream) (format stream (intl:gettext "Bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%") (defmacro-bogus-sublist-error-object condition) (defmacro-bogus-sublist-error-lambda-list condition))))) (define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error) ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument) (lambda-list :reader defmacro-ll-arg-count-error-lambda-list :initarg :lambda-list) (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum) (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum)) (:report (lambda (condition stream) (print-defmacro-ll-bind-error-intro condition stream) (format stream (intl:gettext "Invalid number of elements in:~% ~:S~%~ to satisfy lambda-list:~% ~:S~%") (defmacro-ll-arg-count-error-argument condition) (defmacro-ll-arg-count-error-lambda-list condition)) (cond ((null (defmacro-ll-arg-count-error-maximum condition)) (format stream (intl:gettext "Expected at least ~D") (defmacro-ll-arg-count-error-minimum condition))) ((= (defmacro-ll-arg-count-error-minimum condition) (defmacro-ll-arg-count-error-maximum condition)) (format stream (intl:gettext "Expected exactly ~D") (defmacro-ll-arg-count-error-minimum condition))) (t (format stream (intl:gettext "Expected between ~D and ~D") (defmacro-ll-arg-count-error-minimum condition) (defmacro-ll-arg-count-error-maximum condition)))) (format stream (intl:gettext ", but got ~D.") (length (defmacro-ll-arg-count-error-argument condition)))))) (define-condition defmacro-ll-broken-key-list-error (defmacro-lambda-list-bind-error) ((problem :reader defmacro-ll-broken-key-list-error-problem :initarg :problem) (info :reader defmacro-ll-broken-key-list-error-info :initarg :info)) (:report (lambda (condition stream) (print-defmacro-ll-bind-error-intro condition stream) (format stream (ecase (defmacro-ll-broken-key-list-error-problem condition) (:dotted-list "Keyword/value list is dotted: ~S") (:odd-length "Odd number of elements in keyword/value list: ~S") (:duplicate "Duplicate keyword: ~S") (:unknown-keyword "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}")) (defmacro-ll-broken-key-list-error-info condition))))) cmucl-21a/src/code/defstruct.lisp000066400000000000000000002060251260377556400171630ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: KERNEL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/defstruct.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Defstruct structure definition package (Mark III). ;;; Written by Rob MacLachlan, William Lott and Skef Wholey. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(defstruct copy-structure structure-object)) (in-package "KERNEL") (export '(default-structure-print make-structure-load-form %compiler-defstruct %%compiler-defstruct %compiler-only-defstruct %make-instance %instance-length %instance-ref %instance-set %instance-layout %set-instance-layout %make-funcallable-instance %funcallable-instance-info %set-funcallable-instance-info funcallable-instance-function funcallable-structure funcallable-instance-p %raw-ref-single %raw-set-single %raw-ref-double %raw-set-double defstruct-description dd-name dd-default-constructor dd-copier dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type dsd-index dsd-raw-type dsd-read-only undefine-structure *ansi-defstruct-options-p*)) (defparameter *ANSI-defstruct-options-p* nil "Controls compiling DEFSTRUCT :print-function and :print-method options according to ANSI spec. MUST be NIL to compile CMUCL & PCL") ;;;; Structure frobbing primitives. (defun %make-instance (length) "Allocate a new instance with LENGTH data slots." (declare (type index length)) (%make-instance length)) (defun %instance-length (instance) "Given an instance, return its length." (declare (type instance instance)) (%instance-length instance)) (defun %instance-ref (instance index) "Return the value from the INDEXth slot of INSTANCE. This is SETFable." (%instance-ref instance index)) (defun %instance-set (instance index new-value) "Set the INDEXth slot of INSTANCE to NEW-VALUE." (setf (%instance-ref instance index) new-value)) (defun %raw-ref-single (vec index) (declare (type index index)) (%raw-ref-single vec index)) (defun %raw-ref-double (vec index) (declare (type index index)) (%raw-ref-double vec index)) #+long-float (defun %raw-ref-long (vec index) (declare (type index index)) (%raw-ref-long vec index)) (defun %raw-set-single (vec index val) (declare (type index index)) (%raw-set-single vec index val)) (defun %raw-set-double (vec index val) (declare (type index index)) (%raw-set-double vec index val)) #+long-float (defun %raw-set-long (vec index val) (declare (type index index)) (%raw-set-long vec index val)) (defun %raw-ref-complex-single (vec index) (declare (type index index)) (%raw-ref-complex-single vec index)) (defun %raw-ref-complex-double (vec index) (declare (type index index)) (%raw-ref-complex-double vec index)) #+long-float (defun %raw-ref-complex-long (vec index) (declare (type index index)) (%raw-ref-complex-long vec index)) (defun %raw-set-complex-single (vec index val) (declare (type index index)) (%raw-set-complex-single vec index val)) (defun %raw-set-complex-double (vec index val) (declare (type index index)) (%raw-set-complex-double vec index val)) #+long-float (defun %raw-set-complex-long (vec index val) (declare (type index index)) (%raw-set-complex-long vec index val)) (defun %instance-layout (instance) (%instance-layout instance)) (defun %set-instance-layout (instance new-value) (%set-instance-layout instance new-value)) (defun %make-funcallable-instance (len layout) (%make-funcallable-instance len layout)) (defun funcallable-instance-p (x) (funcallable-instance-p x)) (defun %funcallable-instance-info (fin i) (%funcallable-instance-info fin i)) (defun %set-funcallable-instance-info (fin i new-value) (%set-funcallable-instance-info fin i new-value)) (defun funcallable-instance-function (fin) (%funcallable-instance-lexenv fin)) ;;; The heart of the magic of funcallable instances. The function for a FIN ;;; must be a magical INSTANCE-LAMBDA form. When called (as with any other ;;; function), we grab the code pointer, and call it, leaving the original ;;; function object in LEXENV (in case it was a closure). If it is actually a ;;; FIN, then we need to do an extra indirection with ;;; funcallable-instance-lexenv to get at any closure environment. This extra ;;; indirection is set up when accessing the closure environment of an ;;; INSTANCE-LAMBDA. Note that the original FIN pointer is lost, so if the ;;; called function wants to get at the original object to do some slot ;;; accesses, it must close over the FIN object. ;;; ;;; If we set the FIN function to be a FIN, we directly copy across both the ;;; code pointer and the lexenv, since that code pointer (for an ;;; instance-lambda) is expecting that lexenv to be accessed. This effectively ;;; pre-flattens what would otherwise be a chain of indirections. Lest this ;;; sound like an excessively obscure case, note that it happens when PCL ;;; dispatch functions are byte-compiled. ;;; ;;; The only loss is that if someone accesses the ;;; funcallable-instance-function, then won't get a FIN back. This probably ;;; doesn't matter, since PCL only sets the FIN function. And the only reason ;;; that interpreted functions are FINs instead of bare closures is for ;;; debuggability. ;;; (defun (setf funcallable-instance-function) (new-value fin) (setf (%funcallable-instance-function fin) (%closure-function new-value)) (setf (%funcallable-instance-lexenv fin) (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) new-value))) (defsetf %instance-ref %instance-set) (defsetf %raw-ref-single %raw-set-single) (defsetf %raw-ref-double %raw-set-double) #+long-float (defsetf %raw-ref-long %raw-set-long) (defsetf %raw-ref-complex-single %raw-set-complex-single) (defsetf %raw-ref-complex-double %raw-set-complex-double) #+long-float (defsetf %raw-ref-complex-long %raw-set-complex-long) (defsetf %instance-layout %set-instance-layout) (defsetf %funcallable-instance-info %set-funcallable-instance-info) ;;; This version of Defstruct is implemented using Defstruct, and is free of ;;; Maclisp compatability nonsense. For bootstrapping, you're on your own. ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a ;;; structure type. ;;; (defstruct (defstruct-description (:conc-name dd-) (:print-function print-defstruct-description) (:make-load-form-fun :just-dump-it-normally) (:pure t) (:constructor make-defstruct-description (name))) ;; ;; name of the structure (name (required-argument) :type symbol) ;; ;; documentation on the structure (doc nil :type (or string null)) ;; ;; prefix for slot names. If NIL, none. (conc-name (concat-pnames name '-) :type (or symbol null)) ;; ;; The name of the primary standard keyword constructor, or NIL if none. (default-constructor nil :type (or symbol null)) ;; ;; All the explicit :CONSTRUCTOR specs, with name defaulted. (constructors () :type list) ;; ;; name of copying function (copier (concat-pnames 'copy- name) :type (or symbol null)) ;; ;; Name of type predictate (predicate (concat-pnames name '-p) :type (or symbol null)) ;; ;; The arguments to the :INCLUDE option, or NIL if no included structure. (include nil :type list) ;; ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to ;; define structure-like objects with an arbitrary superclass and that may ;; not have STRUCTURE-CLASS as the metaclass). Syntax is: ;; (superclass-name metaclass-name metaclass-constructor) ;; (alternate-metaclass nil :type list) ;; ;; list of defstruct-slot-description objects for all slots (including ;; included ones). (slots () :type list) ;; ;; Number of elements we've allocated (see also raw-length). (length 0 :type index) ;; ;; General kind of implementation. (type 'structure :type (member structure vector list funcallable-structure)) ;; ;; The next three slots are for :TYPE'd structures (which aren't classes, ;; CLASS-STRUCTURE-P = NIL) ;; ;; Vector element type. (element-type 't) ;; ;; T if :NAMED was explicitly specified, Nil otherwise. (named nil :type boolean) ;; ;; Any INITIAL-OFFSET option on this direct type. (offset nil :type (or index null)) ;; ;; The argument to the PRINT-FUNCTION option, or NIL if none. If we see an ;; explicit (:PRINT-FUNCTION) option, then this is DEFAULT-STRUCTURE-PRINT. ;; See also BASIC-STRUCTURE-CLASS-PRINTER. Only for classed structures. ;; (print-function nil :type (or cons symbol null)) ;; ;; The next four slots are only meaningful in real default structures (TYPE = ;; STRUCTURE). ;; ;; Make-load-form function option. See also STRUCTURE-CLASS-LOAD-FORM-MAKER. (make-load-form-fun nil :type (or symbol cons null)) ;; ;; The index of the raw data vector and the number of words in it. NIL and 0 ;; if not allocated yet. (raw-index nil :type (or index null)) (raw-length 0 :type index) ;; ;; Value of the :PURE option, or :UNSPECIFIED. Only meaningful if ;; CLASS-STRUCTURE-P = T. (pure :unspecified :type (member t nil :substructure :unspecified)) ;; ;; a list of (NAME . INDEX) pairs for accessors of included structures (inherited-accessor-alist () :type list)) (defun print-defstruct-description (structure stream depth) (declare (ignore depth)) (format stream "#" (dd-name structure))) ;;; DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about structure ;;; slots. ;;; (defstruct (defstruct-slot-description (:conc-name dsd-) (:print-function print-defstruct-slot-description) (:pure t) (:make-load-form-fun :just-dump-it-normally)) ;; ;; The name of the slot, a symbol. name ;; ;; its position in the implementation sequence (index (required-argument) :type fixnum) ;; ;; Name of accessor. (accessor nil) default ; default value expression (type t) ; declared type specifier ;; ;; If a raw slot, what it holds. T means not raw. (raw-type t :type (member t single-float double-float #+long-float long-float complex-single-float complex-double-float #+long-float complex-long-float unsigned-byte)) (read-only nil :type (member t nil))) (defun print-defstruct-slot-description (structure stream depth) (declare (ignore depth)) (format stream "#" (dsd-name structure))) (defun dsd-%name (dsd) (symbol-name (dsd-name dsd))) ;;; CLASS-STRUCTURE-P -- Internal ;;; ;;; Return true if Defstruct is a structure with a class. ;;; (defun class-structure-p (defstruct) (member (dd-type defstruct) '(structure funcallable-structure))) ;;; COMPILER-LAYOUT-OR-LOSE -- Internal ;;; ;;; Return the compiler layout for Name. Must be a structure-like class. ;;; (defun compiler-layout-or-lose (name) (let ((res (info type compiler-layout name))) (cond ((not res) (error (intl:gettext "Class not yet defined or was undefined: ~S") name)) ((not (typep (layout-info res) 'defstruct-description)) (error (intl:gettext "Class is not a structure class: ~S") name)) (t res)))) (defun dd-maybe-make-print-method (defstruct) ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object. (let ((print-function-value (dd-print-function defstruct))) (when (consp print-function-value) (let ((kind (car print-function-value)) (function (cdr print-function-value))) (unless (eq kind 'lambda) (setf (dd-print-function defstruct) nil) (let* ((class (dd-name defstruct)) (func (if (symbolp function) `',function `#',function))) ;; We can only generate this code if CLOS is loaded. Maybe should ;; signal an error instead of quietly ignoring the defmethod? `((when (fboundp 'print-object) (defmethod print-object ((object ,class) stream) (funcall ,func object stream ,@(when (or (eq kind :print-function) (eq function 'default-structure-print)) '(*current-level*)))))))))))) ;;; The legendary macro itself. ;;; DEFINE-CLASS-METHODS -- Internal ;;; ;;; Return a list of forms to install print and make-load-form funs, mentioning ;;; them in the expansion so that they can be compiled. ;;; (defun define-class-methods (defstruct) (let* ((name (dd-name defstruct)) (pom (dd-maybe-make-print-method defstruct))) `(,@(let ((pf (dd-print-function defstruct))) (when pf `((setf (basic-structure-class-print-function (find-class ',name)) ,(if (symbolp pf) `',pf `#',pf))))) ,@(let ((mlff (dd-make-load-form-fun defstruct))) (when mlff `((setf (structure-class-make-load-form-fun (find-class ',name)) ,(if (symbolp mlff) `',mlff `#',mlff))))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure 't) `((setf (layout-pure (%class-layout (find-class ',name))) t))) ((eq pure :substructure) `((setf (layout-pure (%class-layout (find-class ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) `((setf (structure-class-constructor (find-class ',name)) #',def-con)))) ,@pom))) #+ORIGINAL (defun define-class-methods (defstruct) (let ((name (dd-name defstruct))) `(,@(let ((pf (dd-print-function defstruct))) (when pf `((setf (basic-structure-class-print-function (find-class ',name)) ,(if (symbolp pf) `',pf `#',pf))))) ,@(let ((mlff (dd-make-load-form-fun defstruct))) (when mlff `((setf (structure-class-make-load-form-fun (find-class ',name)) ,(if (symbolp mlff) `',mlff `#',mlff))))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure 't) `((setf (layout-pure (%class-layout (find-class ',name))) t))) ((eq pure :substructure) `((setf (layout-pure (%class-layout (find-class ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) `((setf (structure-class-constructor (find-class ',name)) #',def-con))))))) (defun accessor-inherited-data (name defstruct) (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq)) ;;; DEFSTRUCT -- Public ;;; (defmacro defstruct (name-and-options &rest slot-descriptions) "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} Define the structure type Name. Instances are created by MAKE-, which takes keyword arguments allowing initial slot values to the specified. A SETF'able function - is defined for each slot to read&write slot values. -p is a type predicate. Popular DEFSTRUCT options (see manual for others): (:CONSTRUCTOR Name) (:PREDICATE Name) Specify an alternate name for the constructor or predicate. (:CONSTRUCTOR Name Lambda-List) Explicitly specify the name and arguments to create a BOA constructor (which is more efficient when keyword syntax isn't necessary.) (:INCLUDE Supertype Slot-Spec*) Make this type a subtype of the structure type Supertype. The optional Slot-Specs override inherited slot options. Slot options: :TYPE Type-Spec Asserts that the value of this slot is always of the specified type. :READ-ONLY {T | NIL} If true, no setter function is defined for this slot." (let* ((defstruct (parse-name-and-options (if (atom name-and-options) (list name-and-options) name-and-options))) (name (dd-name defstruct)) (pkg (symbol-package name))) (when (and lisp::*enable-package-locked-errors* pkg (ext:package-definition-lock pkg)) (restart-case (error 'lisp::package-locked-error :package pkg :format-control (intl:gettext "defining structure ~A") :format-arguments (list name)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable package's definition lock then continue") stream)) (setf (ext:package-definition-lock pkg) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Unlock all packages, then continue") stream)) (lisp::unlock-all-packages)))) (when (info declaration recognized name) (error (intl:gettext "Defstruct already names a declaration: ~S.") name)) (when (stringp (car slot-descriptions)) (setf (dd-doc defstruct) (pop slot-descriptions))) (dolist (slot slot-descriptions) (allocate-1-slot defstruct (parse-1-dsd defstruct slot))) (if (class-structure-p defstruct) (let ((inherits (inherits-for-structure defstruct))) `(progn (%defstruct ',defstruct ',inherits) (%compiler-only-defstruct ',defstruct ',inherits) ,@(when (eq (dd-type defstruct) 'structure) `((%compiler-defstruct ',defstruct))) ,@(define-raw-accessors defstruct) ,@(define-constructors defstruct) ,@(define-class-methods defstruct) (lisp::set-defvar-source-location ',name (c::source-location)) ',name)) `(progn (eval-when (compile load eval) (setf (info typed-structure info ',name) ',defstruct)) ,@(define-constructors defstruct) ,@(define-predicate defstruct) ,@(define-accessors defstruct) ,@(define-copier defstruct) (lisp::set-defvar-source-location ',name (c::source-location)) ',name)))) ;;;; Parsing: ;;; PARSE-1-OPTION -- Internal ;;; ;;; Parse a single defstruct option and store the results in Defstruct. ;;; (defun parse-1-option (option defstruct) (let ((args (rest option)) (name (dd-name defstruct))) (case (first option) (:conc-name (destructuring-bind (&optional conc-name) args (setf (dd-conc-name defstruct) (if (symbolp conc-name) conc-name (make-symbol (string conc-name)))))) (:constructor (destructuring-bind (&optional (cname (concat-pnames 'make- name)) &rest stuff) args (push (cons cname stuff) (dd-constructors defstruct)))) (:copier (destructuring-bind (&optional (copier (concat-pnames 'copy- name))) args (setf (dd-copier defstruct) copier))) (:predicate (destructuring-bind (&optional (pred (concat-pnames name '-p))) args (setf (dd-predicate defstruct) pred))) (:include (when (dd-include defstruct) (error (intl:gettext "Can't have more than one :INCLUDE option."))) (setf (dd-include defstruct) args)) (:alternate-metaclass (setf (dd-alternate-metaclass defstruct) args)) ((:print-function :print-object) (destructuring-bind (&optional (fun 'default-structure-print)) args (setf (dd-print-function defstruct) (if *ANSI-defstruct-options-p* (cons (first option) fun) fun)))) (:type (destructuring-bind (type) args (cond ((eq type 'funcallable-structure) (setf (dd-type defstruct) type)) ((member type '(list vector)) (setf (dd-element-type defstruct) 't) (setf (dd-type defstruct) type)) ((and (consp type) (eq (first type) 'vector)) (destructuring-bind (vector vtype) type (declare (ignore vector)) (setf (dd-element-type defstruct) vtype) (setf (dd-type defstruct) 'vector))) (t (error (intl:gettext "~S is a bad :TYPE for Defstruct.") type))))) (:named (error (intl:gettext "The Defstruct option :NAMED takes no arguments."))) (:initial-offset (destructuring-bind (offset) args (setf (dd-offset defstruct) offset))) (:make-load-form-fun (destructuring-bind (fun) args (setf (dd-make-load-form-fun defstruct) fun))) (:pure (destructuring-bind (fun) args (setf (dd-pure defstruct) fun))) (t (error (intl:gettext "Unknown DEFSTRUCT option~% ~S") option))))) #+ORIGINAL (defun parse-1-option (option defstruct) (let ((args (rest option)) (name (dd-name defstruct))) (case (first option) (:conc-name (destructuring-bind (conc-name) args (setf (dd-conc-name defstruct) (if (symbolp conc-name) conc-name (make-symbol (string conc-name)))))) (:constructor (destructuring-bind (&optional (cname (concat-pnames 'make- name)) &rest stuff) args (push (cons cname stuff) (dd-constructors defstruct)))) (:copier (destructuring-bind (&optional (copier (concat-pnames 'copy- name))) args (setf (dd-copier defstruct) copier))) (:predicate (destructuring-bind (&optional (pred (concat-pnames name '-p))) args (setf (dd-predicate defstruct) pred))) (:include (when (dd-include defstruct) (error (intl:gettext "Can't have more than one :INCLUDE option."))) (setf (dd-include defstruct) args)) (:alternate-metaclass (setf (dd-alternate-metaclass defstruct) args)) (:print-function (destructuring-bind (&optional (fun 'default-structure-print)) args (setf (dd-print-function defstruct) fun))) (:type (destructuring-bind (type) args (cond ((eq type 'funcallable-structure) (setf (dd-type defstruct) type)) ((member type '(list vector)) (setf (dd-element-type defstruct) 't) (setf (dd-type defstruct) type)) ((and (consp type) (eq (first type) 'vector)) (destructuring-bind (vector vtype) type (declare (ignore vector)) (setf (dd-element-type defstruct) vtype) (setf (dd-type defstruct) 'vector))) (t (error (intl:gettext "~S is a bad :TYPE for Defstruct.") type))))) (:named (error (intl:gettext "The Defstruct option :NAMED takes no arguments."))) (:initial-offset (destructuring-bind (offset) args (setf (dd-offset defstruct) offset))) (:make-load-form-fun (destructuring-bind (fun) args (setf (dd-make-load-form-fun defstruct) fun))) (:pure (destructuring-bind (fun) args (setf (dd-pure defstruct) fun))) (t (error (intl:gettext "Unknown DEFSTRUCT option~% ~S") option))))) ;;; PARSE-NAME-AND-OPTIONS -- Internal ;;; ;;; Given name and options, return a DD holding that info. ;;; (defun parse-name-and-options (name-and-options) (destructuring-bind (name &rest options) name-and-options (let ((defstruct (make-defstruct-description name))) (dolist (option options) (cond ((consp option) (parse-1-option option defstruct)) ((eq option :named) (setf (dd-named defstruct) t)) ((member option '(:constructor :copier :predicate :named :conc-name)) (parse-1-option (list option) defstruct)) (t (error (intl:gettext "Unrecognized DEFSTRUCT option: ~S") option)))) (case (dd-type defstruct) (structure (when (dd-offset defstruct) (error (intl:gettext "Can't specify :OFFSET unless :TYPE is specified."))) (unless (dd-include defstruct) (incf (dd-length defstruct)))) (funcallable-structure) (t (when (dd-print-function defstruct) (warn (intl:gettext "Silly to specify :PRINT-FUNCTION with :TYPE."))) (when (dd-make-load-form-fun defstruct) (warn (intl:gettext "Silly to specify :MAKE-LOAD-FORM-FUN with :TYPE."))) (when (dd-named defstruct) (incf (dd-length defstruct))) (let ((offset (dd-offset defstruct))) (when offset (incf (dd-length defstruct) offset))))) (when (dd-include defstruct) (do-inclusion-stuff defstruct)) defstruct))) ;;;; Stuff to parse slot descriptions. ;;; PARSE-1-DSD -- Internal ;;; ;;; Parse a slot description for DEFSTRUCT, add it to the description and ;;; return it. If supplied, ISLOT is a pre-initialized DSD that we modify to ;;; get the new slot. This is supplied when handling included slots. ;;; (defun parse-1-dsd (defstruct spec &optional (islot (make-defstruct-slot-description :name nil :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) (cond ((consp spec) (destructuring-bind (name &optional (default nil default-p) &key (type nil type-p) (read-only nil ro-p)) spec (values name default default-p type type-p read-only ro-p))) (t (when (keywordp spec) (warn (intl:gettext "Keyword slot name indicates probable syntax ~ error in DEFSTRUCT -- ~S.") spec)) spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) (error 'simple-program-error :format-control (intl:gettext "Duplicate slot name ~S.") :format-arguments (list name))) (setf (dsd-name islot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) (setf (dsd-accessor islot) (concat-pnames (dd-conc-name defstruct) name)) (when default-p (setf (dsd-default islot) default)) (when type-p (setf (dsd-type islot) (if (eq (dsd-type islot) 't) type `(and ,(dsd-type islot) ,type)))) (when ro-p (if read-only (setf (dsd-read-only islot) t) (when (dsd-read-only islot) (error (intl:gettext "Slot ~S must be read-only in subtype ~S.") name (dsd-name islot))))) islot)) ;;; ALLOCATE-1-SLOT -- Internal ;;; ;;; Allocate storage for a DSD in Defstruct. This is where we decide if a ;;; slot is raw or not. If raw, and we haven't allocated a raw-index yet for ;;; the raw data vector, then do it. Raw objects are aligned on the unit of ;;; their size. ;;; (defun allocate-1-slot (defstruct dsd) (let ((type (dsd-type dsd))) (multiple-value-bind (raw-type words) (cond ((not (eq (dd-type defstruct) 'structure)) (values nil nil)) ((and (subtypep type '(unsigned-byte 32)) (not (subtypep type 'fixnum))) (values 'unsigned-byte 1)) ((subtypep type 'single-float) (values 'single-float 1)) ((subtypep type 'double-float) (values 'double-float 2)) #+long-float ((subtypep type 'long-float) (values 'long-float #+x86 3 #+sparc 4)) ((subtypep type '(complex single-float)) (values 'complex-single-float 2)) ((subtypep type '(complex double-float)) (values 'complex-double-float 4)) #+long-float ((subtypep type '(complex long-float)) (values 'complex-long-float #+x86 6 #+sparc 8)) (t (values nil nil))) (cond ((not raw-type) (setf (dsd-index dsd) (dd-length defstruct)) (incf (dd-length defstruct))) (t (unless (dd-raw-index defstruct) (setf (dd-raw-index defstruct) (dd-length defstruct)) (incf (dd-length defstruct))) (let ((off (rem (dd-raw-length defstruct) words))) (unless (zerop off) (incf (dd-raw-length defstruct) (- words off)))) (setf (dsd-raw-type dsd) raw-type) (setf (dsd-index dsd) (dd-raw-length defstruct)) (incf (dd-raw-length defstruct) words))))) (undefined-value)) ;;; DO-INCLUSION-STUFF -- Internal ;;; ;;; Process any included slots pretty much like they were specified. Also ;;; inherit various other attributes (print function, etc.) ;;; (defun do-inclusion-stuff (defstruct) (destructuring-bind (included-name &rest modified-slots) (dd-include defstruct) (let* ((type (dd-type defstruct)) (included-structure (if (class-structure-p defstruct) (layout-info (compiler-layout-or-lose included-name)) (typed-structure-info-or-lose included-name)))) (unless (and (eq type (dd-type included-structure)) (type= (specifier-type (dd-element-type included-structure)) (specifier-type (dd-element-type defstruct)))) (error (intl:gettext ":TYPE option mismatch between structures ~S and ~S.") (dd-name defstruct) included-name)) (incf (dd-length defstruct) (dd-length included-structure)) (when (class-structure-p defstruct) (unless (dd-print-function defstruct) (setf (dd-print-function defstruct) (dd-print-function included-structure))) (unless (dd-make-load-form-fun defstruct) (setf (dd-make-load-form-fun defstruct) (dd-make-load-form-fun included-structure))) (let ((mc (rest (dd-alternate-metaclass included-structure)))) (when (and mc (not (dd-alternate-metaclass defstruct))) (setf (dd-alternate-metaclass defstruct) (cons included-name mc)))) (when (eq (dd-pure defstruct) :unspecified) (setf (dd-pure defstruct) (dd-pure included-structure))) (setf (dd-raw-index defstruct) (dd-raw-index included-structure)) (setf (dd-raw-length defstruct) (dd-raw-length included-structure))) (setf (dd-inherited-accessor-alist defstruct) (dd-inherited-accessor-alist included-structure)) (dolist (islot (dd-slots included-structure)) (let* ((iname (dsd-name islot)) (modified (or (find iname modified-slots :key #'(lambda (x) (if (atom x) x (car x))) :test #'string=) `(,iname)))) ;; ;; We stash away an alist of accessors to parents' slots ;; that have already been created to avoid conflicts later ;; so that structures with :INCLUDE and :CONC-NAME (and ;; other edge cases) can work as specified. (when (dsd-accessor islot) ;; the "oldest" (i.e. highest up the tree of inheritance) ;; will prevail, so don't push new ones on if they ;; conflict. (pushnew (cons (dsd-accessor islot) (dsd-index islot)) (dd-inherited-accessor-alist defstruct) :test #'eq :key #'car)) (parse-1-dsd defstruct modified (copy-defstruct-slot-description islot))))))) ;;;; Constructors: (defun typed-structure-info-or-lose (name) (or (info typed-structure info name) (error (intl:gettext ":TYPE'd defstruct ~S not found for inclusion.") name))) ;;; %GET-COMPILER-LAYOUT -- Internal ;;; ;;; Delay looking for compiler-layout until the constructor is being compiled, ;;; since it doesn't exist until after the eval-when (compile) is compiled. ;;; (defmacro %get-compiler-layout (name) `',(compiler-layout-or-lose name)) ;;; FIND-NAME-INDICES -- Internal ;;; ;;; Returns a list of pairs (name . index). Used for :TYPE'd constructors ;;; to find all the names that we have to splice in & where. Note that these ;;; types don't have a layout, so we can't look at LAYOUT-INHERITS. ;;; (defun find-name-indices (defstruct) (collect ((res)) (let ((infos ())) (do ((info defstruct (typed-structure-info-or-lose (first (dd-include info))))) ((not (dd-include info)) (push info infos)) (push info infos)) (let ((i 0)) (dolist (info infos) (incf i (or (dd-offset info) 0)) (when (dd-named info) (res (cons (dd-name info) i))) (setq i (dd-length info))))) (res))) ;;; CREATE-{STRUCTURE,VECTOR,LIST}-CONSTRUCTOR -- Internal ;;; ;;; These functions are called to actually make a constructor after we have ;;; processed the arglist. The correct variant (according to the DD-TYPE) ;;; should be called. The function is defined with the specified name and ;;; arglist. Vars and Types are used for argument type declarations. Values ;;; are the values for the slots (in order). ;;; ;;; This is split four ways because: ;;; 1] list & vector structures need "name" symbols stuck in at various weird ;;; places, whereas STRUCTURE structures have a LAYOUT slot. ;;; 2] We really want to use LIST to make list structures, instead of ;;; MAKE-LIST/(SETF ELT). ;;; 3] STRUCTURE structures can have raw slots that must also be allocated and ;;; indirectly referenced. We use SLOT-ACCESSOR-FORM to compute how to set ;;; the slots, which deals with raw slots. ;;; 4] funcallable structures are weird. ;;; (defun create-vector-constructor (defstruct cons-name arglist vars aux-vars types values) (let ((temp (gensym)) (etype (dd-element-type defstruct))) `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) (append vars aux-vars) types)) (let ((,temp (make-array ,(dd-length defstruct) :element-type ',(dd-element-type defstruct)))) ,@(mapcar #'(lambda (x) `(setf (aref ,temp ,(cdr x)) ',(car x))) (find-name-indices defstruct)) ,@(mapcar #'(lambda (dsd value) `(setf (aref ,temp ,(dsd-index dsd)) ,value)) (dd-slots defstruct) values) ,temp)))) ;;; (defun create-list-constructor (defstruct cons-name arglist vars aux-vars types values) (let ((vals (make-list (dd-length defstruct) :initial-element nil))) (dolist (x (find-name-indices defstruct)) (setf (elt vals (cdr x)) `',(car x))) (loop for dsd in (dd-slots defstruct) and val in values do (setf (elt vals (dsd-index dsd)) val)) `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) (append vars aux-vars) types)) (list ,@vals)))) ;;; (defun create-structure-constructor (defstruct cons-name arglist vars aux-vars types values) (let* ((temp (gensym)) (raw-index (dd-raw-index defstruct)) (n-raw-data (when raw-index (gensym)))) `(defun ,cons-name ,arglist (declare ,@(remove nil (mapcar #'(lambda (var type) (unless (member var aux-vars) `(type ,type ,var))) vars types))) (let ((,temp (truly-the ,(dd-name defstruct) (%make-instance ,(dd-length defstruct)))) ,@(when n-raw-data `((,n-raw-data (make-array ,(dd-raw-length defstruct) :element-type '(unsigned-byte 32)))))) (setf (%instance-layout ,temp) (%get-compiler-layout ,(dd-name defstruct))) ,@(when n-raw-data `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data))) ,@(mapcar #'(lambda (dsd value) (multiple-value-bind (accessor index data) (slot-accessor-form defstruct dsd temp n-raw-data) (let* ((res (dsd-type dsd)) (type (if res `(the ,res ,value) value))) `(setf (,accessor ,data ,index) ,type)))) (dd-slots defstruct) values) ,temp)))) ;;; (defun create-fin-constructor (defstruct cons-name arglist vars aux-vars types values) (let ((temp (gensym))) `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) (append vars aux-vars) types)) (let ((,temp (truly-the ,(dd-name defstruct) (%make-funcallable-instance ,(dd-length defstruct) (%get-compiler-layout ,(dd-name defstruct)))))) ,@(mapcar #'(lambda (dsd value) `(setf (%funcallable-instance-info ,temp ,(dsd-index dsd)) ,value)) (dd-slots defstruct) values) ,temp)))) ;;; CREATE-KEYWORD-CONSTRUCTOR -- Internal ;;; ;;; Create a default (non-BOA) keyword constructor. ;;; (defun create-keyword-constructor (defstruct creator) (collect ((arglist (list '&key)) (types) (vals)) (dolist (slot (dd-slots defstruct)) (let ((dum (gensym)) (name (dsd-name slot))) (arglist `((,(intern (string name) "KEYWORD") ,dum) ,(dsd-default slot))) (types (dsd-type slot)) (vals dum))) (funcall creator defstruct (dd-default-constructor defstruct) (arglist) (vals) nil (types) (vals)))) ;;; CREATE-BOA-CONSTRUCTOR -- Internal ;;; ;;; Given a structure and a BOA constructor spec, call Creator with the ;;; appropriate args to make a constructor. ;;; (defun create-boa-constructor (defstruct boa creator) (multiple-value-bind (req opt restp rest keyp keys allowp aux) (kernel:parse-lambda-list (second boa)) (collect ((arglist) (vars) (aux-vars) (types)) (labels ((get-slot (name) (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name))) (if res (values (dsd-type res) (dsd-default res)) (values t nil)))) (do-default (arg) (multiple-value-bind (type default) (get-slot arg) (arglist `(,arg ,default)) (vars arg) (types type)))) (dolist (arg req) (arglist arg) (vars arg) (types (get-slot arg))) (when opt (arglist '&optional) (dolist (arg opt) (if (consp arg) (destructuring-bind (name &optional (def (nth-value 1 (get-slot name))) (supplied-test nil supplied-test-p)) arg (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types (get-slot name))) (do-default arg)))) (when restp (arglist '&rest rest) (vars rest) (types 'list)) (when keyp (arglist '&key) (dolist (arg keys) (if (consp arg) (destructuring-bind (name-spec &optional (def nil def-p) (supplied-test nil supplied-test-p)) arg (let ((name (if (consp name-spec) (destructuring-bind (key var) name-spec (declare (ignore key)) var) name-spec))) (multiple-value-bind (type slot-def) (get-slot name) (arglist `(,name-spec ,(if def-p def slot-def) ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types type)))) (do-default arg)))) (when allowp (arglist '&allow-other-keys)) (when aux (arglist '&aux) (dolist (arg aux) (let* ((arg (if (consp arg) arg (list arg))) (var (first arg))) (arglist arg) (aux-vars var) (types (get-slot var)))))) (funcall creator defstruct (first boa) (arglist) (vars) (aux-vars) (types) (mapcar #'(lambda (slot) (let ((v (find (dsd-name slot) (vars) :test #'string=))) (if v v (let ((aux (find (dsd-name slot) (aux-vars) :test #'string=))) (if aux `(or ,aux ,(dsd-default slot)) (dsd-default slot)))))) (dd-slots defstruct)))))) ;;; DEFINE-CONSTRUCTORS -- Internal ;;; ;;; Grovel the constructor options, and decide what constructors (if any) to ;;; create. ;;; (defun define-constructors (defstruct) (let ((no-constructors nil) (boas ()) (defaults ()) (creator (ecase (dd-type defstruct) (structure #'create-structure-constructor) (funcallable-structure #'create-fin-constructor) (vector #'create-vector-constructor) (list #'create-list-constructor)))) (dolist (constructor (dd-constructors defstruct)) (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor (declare (ignore boa-ll)) (cond ((not name) (setq no-constructors t)) (boa-p (push constructor boas)) (t (push name defaults))))) (when no-constructors (when (or defaults boas) (error (intl:gettext "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))) (return-from define-constructors ())) (unless (or defaults boas) (push (concat-pnames 'make- (dd-name defstruct)) defaults)) (collect ((res)) (when defaults (let ((cname (first defaults))) (setf (dd-default-constructor defstruct) cname) (res (create-keyword-constructor defstruct creator)) (dolist (other-name (rest defaults)) (res `(setf (fdefinition ',other-name) (fdefinition ',cname))) (res `(declaim (ftype function ,other-name)))))) (dolist (boa boas) (res (create-boa-constructor defstruct boa creator))) (res)))) ;;;; Slot accessors for raw slots: ;;; SLOT-ACCESSOR-FORM -- Internal ;;; ;;; Return info about how to read/write a slot in the value stored in ;;; Object. This is also used by constructors (we can't use the accessor ;;; function, since some slots are read-only). If supplied, Data is a variable ;;; holding the raw-data vector. ;;; ;;; Values: ;;; 1] Accessor function name (setfable) ;;; 2] Index to pass to accessor. ;;; 3] Object form to pass to accessor. ;;; (defun slot-accessor-form (defstruct slot &optional (object 'object) data) (let ((rtype (dsd-raw-type slot))) (values (ecase rtype (single-float '%raw-ref-single) (double-float '%raw-ref-double) #+long-float (long-float '%raw-ref-long) (complex-single-float '%raw-ref-complex-single) (complex-double-float '%raw-ref-complex-double) #+long-float (complex-long-float '%raw-ref-complex-long) (unsigned-byte 'aref) ((t) (if (eq (dd-type defstruct) 'funcallable-structure) '%funcallable-instance-info '%instance-ref))) (case rtype #+long-float (complex-long-float (truncate (dsd-index slot) #+x86 6 #+sparc 8)) #+long-float (long-float (truncate (dsd-index slot) #+x86 3 #+sparc 4)) (double-float (ash (dsd-index slot) -1)) (complex-double-float (ash (dsd-index slot) -2)) (complex-single-float (ash (dsd-index slot) -1)) (t (dsd-index slot))) (cond ((eq rtype 't) object) (data) (t `(truly-the (simple-array (unsigned-byte 32) (*)) (%instance-ref ,object ,(dd-raw-index defstruct)))))))) ;;; dsd-inherited-p -- Internal ;;; ;;; True when the defstruct slot has been inherited from an included ;;; structure. ;;; (defun dsd-inherited-p (defstruct slot) (assoc (dsd-accessor slot) (dd-inherited-accessor-alist defstruct) :test #'eq)) ;;; DEFINE-RAW-ACCESSORS -- Internal ;;; ;;; Define readers and writers for raw slots as inline functions. We use ;;; the special RAW-REF operations to store floats in the raw data vector. We ;;; also define FIN accessors here. ;;; (defun define-raw-accessors (defstruct) (let ((name (dd-name defstruct))) (collect ((res)) (dolist (slot (dd-slots defstruct)) (let ((stype (dsd-type slot)) (aname (dsd-accessor slot))) (multiple-value-bind (accessor offset data) (slot-accessor-form defstruct slot) (unless (or (dsd-inherited-p defstruct slot) (eq accessor '%instance-ref)) (res `(declaim (inline ,aname))) (res `(declaim (ftype (function (,name) ,stype) ,aname))) (res `(defun ,aname (object) (truly-the ,stype (,accessor ,data ,offset)))) (unless (dsd-read-only slot) (res `(declaim (inline (setf ,aname)))) (res `(declaim (ftype (function (,stype ,name) ,stype) (setf ,aname)))) (res `(defun (setf ,aname) (new-value object) (setf (,accessor ,data ,offset) new-value) new-value))))))) (when (eq (dd-type defstruct) 'funcallable-structure) (let ((pred (dd-predicate defstruct))) (when pred (res `(declaim (inline ,pred))) (res `(defun ,pred (x) (typep x ',name)))))) (res)))) ;;;; Typed (non-class) structures: ;;; DD-LISP-TYPE -- Internal ;;; ;;; Return a type specifier we can use for testing :TYPE'd structures. ;;; (defun dd-lisp-type (defstruct) (ecase (dd-type defstruct) (list 'list) (vector `(simple-array ,(dd-element-type defstruct) (*))))) ;;; DEFINE-ACCESSORS -- Internal ;;; ;;; Returns a list of function definitions for accessing and setting the ;;; slots of the a typed Defstruct. The functions are proclaimed to be inline, ;;; and the types of their arguments and results are declared as well. We ;;; count on the compiler to do clever things with Elt. ;;; (defun define-accessors (defstruct) (collect ((stuff)) (let ((ltype (dd-lisp-type defstruct))) (dolist (slot (dd-slots defstruct)) (let* ((aname (dsd-accessor slot)) (index (dsd-index slot)) (slot-type `(and ,(dsd-type slot) ,(dd-element-type defstruct))) (inherited (accessor-inherited-data aname defstruct))) (cond ((not inherited) (stuff `(declaim (inline ,aname (setf ,aname)))) (stuff `(defun ,aname (structure) (declare (type ,ltype structure)) (the ,slot-type (elt structure ,index)))) (unless (dsd-read-only slot) (stuff `(defun (setf ,aname) (new-value structure) (declare (type ,ltype structure) (type ,slot-type new-value)) (setf (elt structure ,index) new-value))))) ((not (= (cdr inherited) index)) (warn 'simple-style-warning :format-control (intl:gettext "~@") :format-arguments (list aname (dsd-%name slot)))))) )) (stuff))) ;;; Define-Copier returns the definition for a copier function of a typed ;;; Defstruct if one is desired. (defun define-copier (defstruct) (when (dd-copier defstruct) `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq) (declaim (ftype function ,(dd-copier defstruct)))))) ;;; Define-Predicate returns a definition for a predicate function if one is ;;; desired. Rather vaguely specified w.r.t. inclusion. ;;; (defun define-predicate (defstruct) (let ((name (dd-name defstruct)) (pred (dd-predicate defstruct))) (when (and pred (dd-named defstruct)) (let ((ltype (dd-lisp-type defstruct)) (index (cdr (car (last (find-name-indices defstruct)))))) (if (eq ltype 'list) `((defun ,pred (object) (and (typep object 'list) (defstruct-list-p ,index object ',name)))) `((defun ,pred (object) (and (typep object 'vector) (array-in-bounds-p object ,index) (eq (aref object ,index) ',name))))))))) ;; A predicate to determine if the given list is a defstruct object of ;; :type list. This used to be done using (eq (nth index object) name), ;; but that fails if the (nth index object) doesn't work because object ;; is not a proper list. (defun defstruct-list-p (index list name) ;; Basically do (nth index list), but don't crash if the list is not ;; a proper list. (declare (type index index) (type list list)) (do ((i index (1- i)) (result list (cdr result))) ((or (atom result) (not (plusp i))) (unless (atom result) (eq (car result) name))) (declare (type index i)))) ;;;; Load time support for default structures (%DEFSTRUCT) ;;; ;;; In the normal case of structures that have a real type (i.e., no :Type ;;; option was specified), we want to optimize things for space as well as ;;; speed, since there can be thousands of defined slot accessors. ;;; ;;; What we do is defined the accessors and copier as closures over ;;; general-case code. Since the compiler will normally open-code accessors, ;;; the (minor) efficiency penalty is not a concern. ;;; Typep-To-Layout -- Internal ;;; ;;; Return true if Obj is an object of the structure type corresponding to ;;; Layout. This is called by the accessor closures, which have a handle on ;;; the type's layout. ;;; (declaim (inline typep-to-layout)) (defun typep-to-layout (obj layout &optional no-error) (declare (type layout layout) (optimize (speed 3) (safety 0))) (when (layout-invalid layout) (error (intl:gettext "Obsolete structure accessor function called."))) (and (%instancep obj) (let ((depth (layout-inheritance-depth layout)) (obj-layout (%instance-layout obj))) (cond ((eq obj-layout layout) t) ((layout-invalid obj-layout) (if no-error nil (error 'layout-invalid :expected-type (layout-class obj-layout) :datum obj))) (t (and (> (layout-inheritance-depth obj-layout) depth) (eq (svref (layout-inherits obj-layout) depth) layout))))))) ;;; STRUCTURE-SLOT-SETTER, STRUCTURE-SLOT-ACCESSOR -- Internal ;;; ;;; Return closures to do slot access (set), according to Layout and DSD. ;;; We check types, then do the access. This is only used for normal slots ;;; (not raw.) ;;; (defun structure-slot-accessor (layout dsd) (let ((class (layout-class layout))) (if (typep class 'basic-structure-class) #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (unless (typep-to-layout structure layout) (error 'simple-type-error :datum structure :expected-type class :format-control (intl:gettext "Structure for accessor ~S is not a ~S:~% ~S") :format-arguments (list (dsd-accessor dsd) (%class-name class) structure))) (%instance-ref structure (dsd-index dsd))) #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (unless (%typep structure class) (error 'simple-type-error :datum structure :expected-type class :format-control (intl:gettext "Structure for accessor ~S is not a ~S:~% ~S") :format-arguments (list (dsd-accessor dsd) class structure))) (%instance-ref structure (dsd-index dsd)))))) ;;; (defun structure-slot-setter (layout dsd) (let ((class (layout-class layout))) (if (typep class 'basic-structure-class) #'(lambda (new-value structure) (declare (optimize (speed 3) (safety 0))) (unless (typep-to-layout structure layout) (error 'simple-type-error :datum structure :expected-type class :format-control (intl:gettext "Structure for setter ~S is not a ~S:~% ~S") :format-arguments (list `(setf ,(dsd-accessor dsd)) (%class-name class) structure))) (unless (%typep new-value (dsd-type dsd)) (error 'simple-type-error :datum new-value :expected-type (dsd-type dsd) :format-control (intl:gettext "New-Value for setter ~S is not a ~S:~% ~S.") :format-arguments (list `(setf ,(dsd-accessor dsd)) (dsd-type dsd) new-value))) (setf (%instance-ref structure (dsd-index dsd)) new-value)) #'(lambda (new-value structure) (declare (optimize (speed 3) (safety 0))) (unless (%typep structure class) (error 'simple-type-error :datum structure :expected-type class :format-control (intl:gettext "Structure for setter ~S is not a ~S:~% ~S") :format-arguments (list `(setf ,(dsd-accessor dsd)) (%class-name class) structure))) (unless (%typep new-value (dsd-type dsd)) (error 'simple-type-error :datum new-value :expected-type (dsd-type dsd) :format-control (intl:gettext "New-Value for setter ~S is not a ~S:~% ~S.") :format-arguments (list `(setf ,(dsd-accessor dsd)) (dsd-type dsd) new-value))) (setf (%instance-ref structure (dsd-index dsd)) new-value))))) ;;; ;;; Used for updating CLOS structure classes. Hooks are called ;;; with one argument, the kernel::class. ;;; (defvar *defstruct-hooks* nil) ;;; %Defstruct -- Internal ;;; ;;; Do miscellaneous (LOAD EVAL) time actions for the structure described by ;;; Info. Create the class & layout, checking for incompatible redefinition. ;;; Define setters, accessors, copier, predicate, documentation, instantiate ;;; definition in load-time env. This is only called for default structures. ;;; (defun %defstruct (info inherits) (declare (type defstruct-description info)) (multiple-value-bind (class layout old-layout) (ensure-structure-class info inherits "current" "new") (cond ((not old-layout) (unless (eq (%class-layout class) layout) (register-layout layout))) (t (let ((old-info (layout-info old-layout))) (when (defstruct-description-p old-info) (dolist (slot (dd-slots old-info)) (unless (dsd-inherited-p old-info slot) (let ((aname (dsd-accessor slot))) (fmakunbound aname) (unless (dsd-read-only slot) (fmakunbound `(setf ,aname)))))))) (%redefine-defstruct class old-layout layout) (setq layout (%class-layout class)))) (setf (find-class (dd-name info)) class) (unless (eq (dd-type info) 'funcallable-structure) (dolist (slot (dd-slots info)) (unless (or (dsd-inherited-p info slot) (not (eq (dsd-raw-type slot) 't))) (let* ((aname (dsd-accessor slot)) (inherited (accessor-inherited-data aname info))) (unless inherited (setf (symbol-function aname) (structure-slot-accessor layout slot)) (unless (dsd-read-only slot) (setf (fdefinition `(setf ,aname)) (structure-slot-setter layout slot))))) )) (when (dd-predicate info) (setf (symbol-function (dd-predicate info)) #'(lambda (object) (declare (optimize (speed 3) (safety 0))) (typep-to-layout object layout t)))) (when (dd-copier info) (setf (symbol-function (dd-copier info)) #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (unless (typep-to-layout structure layout) (error 'simple-type-error :datum structure :expected-type class :format-control (intl:gettext "Structure for copier is not a ~S:~% ~S") :format-arguments (list class structure))) (copy-structure structure)))) (when (boundp '*defstruct-hooks*) (dolist (fn *defstruct-hooks*) (funcall fn class))))) (when (dd-doc info) (setf (documentation (dd-name info) 'type) (dd-doc info))) (undefined-value)) ;;;; Redefinition stuff: ;;; ENSURE-STRUCTURE-CLASS -- Internal ;;; ;;; Called when we are about to define a structure class. Returns a ;;; (possibly new) class object and the layout which should be used for the new ;;; definition (may be the current layout, and also might be an uninstalled ;;; forward referenced layout.) The third value is true if this is an ;;; incompatible redefinition, in which case it is the old layout. ;;; (defun ensure-structure-class (info inherits old-context new-context &optional compiler-layout) (multiple-value-bind (class old-layout) (destructuring-bind (&optional name (class 'kernel::structure-class) (constructor 'make-structure-class)) (dd-alternate-metaclass info) (declare (ignore name)) (insured-find-class (dd-name info) (if (eq class 'kernel::structure-class) #'(lambda (x) (typep x 'kernel::structure-class)) #'(lambda (x) (typep x (find-class class)))) (fdefinition constructor))) (setf (%class-direct-superclasses class) (if (eq (dd-name info) 'lisp-stream) ;; Hack to add stream as a superclass mixin to lisp-streams. (list (layout-class (svref inherits (1- (length inherits)))) (layout-class (svref inherits (- (length inherits) 2)))) (list (layout-class (svref inherits (1- (length inherits))))))) (let ((new-layout (make-layout :class class :inherits inherits :inheritance-depth (length inherits) :length (dd-length info) :info info)) (old-layout (or compiler-layout old-layout))) (cond ((not old-layout) (values class new-layout nil)) ((not *type-system-initialized*) (setf (layout-info old-layout) info) (values class old-layout nil)) ((redefine-layout-warning old-layout old-context new-layout new-context) (values class new-layout old-layout)) (t (let ((old-info (layout-info old-layout))) (typecase old-info ((or defstruct-description) (cond ((redefine-structure-warning class old-info info) (values class new-layout old-layout)) (t (setf (layout-info old-layout) info) (values class old-layout nil)))) (null (setf (layout-info old-layout) info) (values class old-layout nil)) (t (warn (intl:gettext "Shouldn't happen! Some strange thing in LAYOUT-INFO:~ ~% ~S") old-layout) (values class new-layout old-layout))))))))) ;;; COMPARE-SLOTS -- Internal ;;; ;;; Compares the slots of Old and New, returning 3 lists of slot names: ;;; 1] Slots which have moved, ;;; 2] Slots whose type has changed, ;;; 3] Deleted slots. ;;; (defun compare-slots (old new) (let* ((oslots (dd-slots old)) (nslots (dd-slots new)) (onames (mapcar #'dsd-name oslots)) (nnames (mapcar #'dsd-name nslots))) (collect ((moved) (retyped)) (dolist (name (intersection onames nnames)) (let ((os (find name oslots :key #'dsd-name)) (ns (find name nslots :key #'dsd-name))) (unless (subtypep (dsd-type ns) (dsd-type os)) (retyped name)) (unless (and (= (dsd-index os) (dsd-index ns)) (eq (dsd-raw-type os) (dsd-raw-type ns))) (moved name)))) (values (moved) (retyped) (set-difference onames nnames))))) ;;; REDEFINE-STRUCTURE-WARNING -- Internal ;;; ;;; Give a warning and return true if we are redefining a structure with ;;; different slots than in the currently loaded version. ;;; (defun redefine-structure-warning (class old new) (declare (type defstruct-description old new) (type kernel::class class) (ignore class)) (let ((name (dd-name new))) (multiple-value-bind (moved retyped deleted) (compare-slots old new) (when (or moved retyped deleted) (warn (intl:gettext "Incompatibly redefining slots of structure class ~S~@ Make sure any uses of affected accessors are recompiled:~@ ~@[ These slots were moved to new positions:~% ~S~%~]~ ~@[ These slots have new incompatible types:~% ~S~%~]~ ~@[ These slots were deleted:~% ~S~%~]") name moved retyped deleted) t)))) ;;; %REDEFINE-DEFSTRUCT -- Internal ;;; ;;; This function is called when we are incompatibly redefining a structure ;;; Class to have the specified New-Layout. We signal an error with some ;;; proceed options and return the layout that should be used. ;;; #+bootstrap-dynamic-extent (defun %redefine-defstruct (class old-layout new-layout) (declare (type class class) (type layout old-layout new-layout)) (register-layout new-layout :invalidate nil :destruct-layout old-layout)) #-bootstrap-dynamic-extent (defun %redefine-defstruct (class old-layout new-layout) (declare (type class class) (type layout old-layout new-layout)) (let ((name (class-proper-name class))) (restart-case (error (intl:gettext "Redefining class ~S incompatibly with the current ~ definition.") name) (continue () :report (lambda (stream) (write-string (intl:gettext "Invalidate already loaded code and instances, use new definition.") stream)) (warn (intl:gettext "Previously loaded ~S accessors will no longer work.") name) (register-layout new-layout)) (clobber-it () :report (lambda (stream) (write-string "Assume redefinition is compatible, allow old code and instances." stream)) (warn (intl:gettext "Any old ~S instances will be in a bad way.~@ I hope you know what you're doing...") name) (register-layout new-layout :invalidate nil :destruct-layout old-layout)))) (undefined-value)) ;;; UNDEFINE-STRUCTURE -- Interface ;;; ;;; Blow away all the compiler info for the structure CLASS. ;;; Iterate over this type, clearing the compiler structure ;;; type info, and undefining all the associated functions. ;;; (defun undefine-structure (class) (let ((info (layout-info (%class-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (setf (info type compiler-layout type) nil) (undefine-function-name (dd-copier info)) (undefine-function-name (dd-predicate info)) (dolist (slot (dd-slots info)) (unless (dsd-inherited-p info slot) (let ((aname (dsd-accessor slot))) (unless (accessor-inherited-data aname info) (undefine-function-name aname) (unless (dsd-read-only slot) (undefine-function-name `(setf ,aname)))) )))) ;; ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are ;; unknown types. (values-specifier-type-cache-clear))) (undefined-value)) ;;;; Compiler stuff: ;;; DEFINE-DEFSTRUCT-NAME -- Internal ;;; ;;; Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and ;;; blow away any ASSUMED-TYPE. Also, if the thing is a slot accessor ;;; currently, quietly unaccessorize it. And if there are any undefined ;;; warnings, we nuke them. ;;; (defun define-defstruct-name (name) (when name (when (info function accessor-for name) (setf (info function accessor-for name) nil)) (define-function-name name) (note-name-defined name :function) (setf (info function where-from name) :declared) (when (info function assumed-type name) (setf (info function assumed-type name) nil))) (undefined-value)) ;;; INHERITS-FOR-STRUCTURE -- Internal ;;; ;;; This function is called at macroexpand time to compute the INHERITS ;;; vector for a structure type definition. ;;; (defun inherits-for-structure (info) (declare (type defstruct-description info)) (let* ((include (dd-include info)) (superclass-opt (dd-alternate-metaclass info)) (super (if include (compiler-layout-or-lose (first include)) (%class-layout (find-class (or (first superclass-opt) 'structure-object)))))) (if (eq (dd-name info) 'lisp-stream) ;; Hack to add the stream class as a mixin for lisp-streams. (concatenate 'simple-vector (layout-inherits super) (vector super (%class-layout (find-class 'stream)))) (concatenate 'simple-vector (layout-inherits super) (vector super))))) ;;; %COMPILER-ONLY-DEFSTRUCT -- Internal ;;; ;;; This function is called at compile-time to do the compile-time-only ;;; actions for defining a structure type. It installs the class in the type ;;; system in a similar way to %DEFSTRUCT, but is quieter and safer in the case ;;; of redefinition. Eval-when doesn't do the right thing when nested or ;;; non-top-level, so this is magically called by the compiler. ;;; ;;; Basically, this function avoids trashing the compiler by only actually ;;; defining the class if there is no current definition. Instead, we just set ;;; the INFO TYPE COMPILER-LAYOUT. ;;; (defun %compiler-only-defstruct (info inherits) (multiple-value-bind (class layout old-layout) (multiple-value-bind (clayout clayout-p) (info type compiler-layout (dd-name info)) (ensure-structure-class info inherits (if clayout-p "previously compiled" "current") "compiled" clayout)) (cond (old-layout (undefine-structure (layout-class old-layout)) (when (and (%class-subclasses class) (not (eq layout old-layout))) (collect ((subs)) (do-hash (class layout (%class-subclasses class)) (declare (ignore layout)) (undefine-structure class) (subs (class-proper-name class))) (when (subs) (warn (intl:gettext "Removing old subclasses of ~S:~% ~S") (%class-name class) (subs)))))) (t (unless (eq (%class-layout class) layout) (register-layout layout :invalidate nil)) (setf (find-class (dd-name info)) class))) (setf (info type compiler-layout (dd-name info)) layout)) (undefined-value)) ;;; %%Compiler-Defstruct -- External ;;; ;;; This function does the (compile load eval) time actions for updating the ;;; compiler's global meta-information to represent the definition of the ;;; structure described by Info. This primarily amounts to setting up info ;;; about the accessor and other implicitly defined functions. The ;;; constructors are explicitly defined by top-level code. ;;; (defun %%compiler-defstruct (info) (declare (type defstruct-description info)) (let* ((name (dd-name info)) (class (find-class name))) (let ((copier (dd-copier info))) (when copier (proclaim `(ftype (function (,name) ,name) ,copier)))) (let ((pred (dd-predicate info))) (when pred (define-defstruct-name pred) (setf (info function inlinep pred) :inline) (setf (info function inline-expansion pred) `(lambda (x) (typep x ',name))))) (dolist (slot (dd-slots info)) (let* ((aname (dsd-accessor slot)) (setf-fun `(setf ,aname)) (inherited (and aname (accessor-inherited-data aname info)))) (cond (inherited (unless (= (cdr inherited) (dsd-index slot)) (warn 'simple-style-warning :format-control (intl:gettext "~@") :format-arguments (list aname (dsd-%name slot))))) (t (unless (or (dsd-inherited-p info slot) (not (eq (dsd-raw-type slot) 't))) (define-defstruct-name aname) (setf (info function accessor-for aname) class) (unless (dsd-read-only slot) (define-defstruct-name setf-fun) (setf (info function accessor-for setf-fun) class))))) ))) (undefined-value)) (setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct) ;;; COPY-STRUCTURE -- Public ;;; ;;; Copy any old kind of structure. ;;; (defun copy-structure (structure) "Return a copy of Structure with the same (EQL) slot values." (declare (type structure-object structure) (optimize (speed 3) (safety 0))) (let* ((len (%instance-length structure)) (res (%make-instance len)) (layout (%instance-layout structure))) (declare (type index len)) (when (layout-invalid layout) (error (intl:gettext "Copying an obsolete structure:~% ~S") structure)) (dotimes (i len) (declare (type index i)) (setf (%instance-ref res i) (%instance-ref structure i))) (let ((raw-index (dd-raw-index (layout-info layout)))) (when raw-index (let* ((data (%instance-ref structure raw-index)) (raw-len (length data)) (new (make-array raw-len :element-type '(unsigned-byte 32)))) (declare (type (simple-array (unsigned-byte 32) (*)) data)) (setf (%instance-ref res raw-index) new) (dotimes (i raw-len) (setf (aref new i) (aref data i)))))) res)) ;;; Default print and make-load-form methods. (defun default-structure-print (structure stream depth) (declare (ignore depth)) (if (funcallable-instance-p structure) (print-unreadable-object (structure stream :identity t :type t) (write-string "Funcallable Structure" stream)) (let* ((type (%instance-layout structure)) (name (%class-name (layout-class type))) (dd (layout-info type))) (cond ((and (null (dd-slots dd)) *print-level* (>= *current-level* *print-level*)) ;; The CLHS entry for *PRINT-LENGTH* says "If an object to ;; be recursively printed has components and is at a level ;; equal to or greater than the value of *print-level*, ;; then the object is printed as ``#''." ;; ;; So, if it has no components, and we're at *PRINT-LEVEL*, ;; we print out #S(). (write-string "#S(" stream) (prin1 name stream) (write-char #\) stream)) (*print-pretty* (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) (let ((slots (dd-slots dd))) (when slots (write-char #\space stream) (pprint-indent :block 2 stream) (pprint-newline :linear stream) (loop (pprint-pop) (let ((slot (pop slots))) (write-char #\: stream) (output-symbol-name (dsd-%name slot) stream) (write-char #\space stream) (pprint-newline :miser stream) (output-object (funcall (fdefinition (dsd-accessor slot)) structure) stream) (when (null slots) (return)) (write-char #\space stream) (pprint-newline :linear stream))))))) (t (descend-into (stream) (write-string "#S(" stream) (prin1 name stream) (do ((index 0 (1+ index)) (slots (dd-slots dd) (cdr slots))) ((or (null slots) (and (not *print-readably*) (eql *print-length* index))) (if (null slots) (write-string ")" stream) (write-string " ...)" stream))) (declare (type index index)) (write-char #\space stream) (write-char #\: stream) (let ((slot (first slots))) (output-symbol-name (dsd-%name slot) stream) (write-char #\space stream) (output-object (funcall (fdefinition (dsd-accessor slot)) structure) stream))))))))) (defun make-structure-load-form (structure) (declare (type structure-object structure)) (let* ((class (layout-class (%instance-layout structure))) (fun (structure-class-make-load-form-fun class))) (etypecase fun ((member :just-dump-it-normally :ignore-it) fun) (null (error (intl:gettext "Structures of type ~S cannot be dumped as constants.") (%class-name class))) (function (funcall fun structure)) (symbol (funcall (symbol-function fun) structure))))) cmucl-21a/src/code/describe.lisp000066400000000000000000000433541260377556400167440ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/describe.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This is the describe mechanism for Common Lisp. ;;; ;;; Written by Skef Wholey or Rob MacLachlan originally. ;;; Cleaned up, reorganized, and enhanced by Blaine Burks. ;;; Ported to the new system and cleaned up some more by Rob MacLachlan. ;;; ;;; This should be done better using CLOS more effectively once CMU Common ;;; Lisp is brought up to the new standard. The TYPECASE in DESCRIBE-AUX ;;; should be unnecessary. -- Bill Chiles ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(describe)) (in-package "EXT") (export '(*describe-level* *describe-verbose* *describe-print-level* *describe-print-length* *describe-indentation*)) (in-package "LISP") ;;;; DESCRIBE public switches. (defvar *describe-level* 2 "Depth of recursive descriptions allowed.") (defvar *describe-verbose* nil "If non-nil, descriptions may provide interpretations of information and pointers to additional information. Normally nil.") (defvar *describe-print-level* 2 "*print-level* gets bound to this inside describe. If null, use *print-level*") (defvar *describe-print-length* 5 "*print-length* gets bound to this inside describe. If null, use *print-length*.") (defvar *describe-indentation* 3 "Number of spaces that sets off each line of a recursive description.") (defvar *in-describe* nil "Used to tell whether we are doing a recursive describe.") (defvar *current-describe-level* 0 "Used to implement recursive description cutoff. Don't touch.") (defvar *describe-output* nil "An output stream used by Describe for indenting and stuff.") (defvar *described-objects* nil "List of all objects describe within the current top-level call to describe.") (defvar *current-describe-object* nil "The last object passed to describe.") ;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the ;;; hard stuff. ;;; (defun describe (x &optional stream) "Prints a description of the object X." (declare (type (or stream (member t nil)) stream)) (unless *describe-output* (setq *describe-output* (make-indenting-stream *standard-output*))) (cond (*in-describe* (unless (or (eq x nil) (eq x t)) (let ((*current-describe-level* (1+ *current-describe-level*)) (*current-describe-object* x)) (indenting-further *describe-output* *describe-indentation* (describe-aux x))))) (t (setf (indenting-stream-stream *describe-output*) (case stream ((t) *terminal-io*) ((nil) *standard-output*) (t stream))) (let ((*standard-output* *describe-output*) (*print-level* (or *describe-print-level* *print-level*)) (*print-length* (or *describe-print-length* *print-length*)) (*described-objects* ()) (*in-describe* t) (*current-describe-object* x)) (describe-aux x)) (values)))) ;;; DESCRIBE-AUX does different things for each type. We punt a given call if ;;; the current level is greater than *describe-level*, or if we detect an ;;; object into which we have already descended. ;;; (defun describe-aux (x) (when (or (not (integerp *describe-level*)) (minusp *describe-level*)) (error (intl:gettext "*describe-level* should be a nonnegative integer - ~A.") *describe-level*)) (when (or (>= *current-describe-level* *describe-level*) (member x *described-objects*)) (return-from describe-aux x)) (push x *described-objects*) (typecase x (symbol (describe-symbol x)) (function (describe-function x)) (package (describe-package x)) (hash-table (describe-hash-table x)) (instance (describe-instance x)) (array (describe-array x)) (fixnum (describe-fixnum x)) (character (describe-character x)) #+double-double (double-double-float (describe-double-double-float x)) (cons (if (and (valid-function-name-p x) (fboundp x)) (describe-function (fdefinition x) :function x) (default-describe x))) (t (default-describe x))) x) ;;;; Implementation properties. ;;; This suppresses random garbage that users probably don't want to see. ;;; (defparameter *implementation-properties* '(%loaded-address CONDITIONS::MAKE-FUNCTION CONDITIONS::REPORT-FUNCTION CONDITIONS::CONC-NAME CONDITIONS::SLOTS CONDITIONS::PARENT-TYPE)) ;;;; Miscellaneous DESCRIBE methods: (defun default-describe (x) (format t (intl:gettext "~&~S is a ~S.") x (type-of x))) (defun describe-character (x) (format t (intl:gettext "~&~S is a ~S.") x (type-of x)) (format t (intl:gettext "~&Its code is #x~4,'0x.") (char-code x)) (format t (intl:gettext "~&Its name is ~A.") (char-name x)) (when (surrogatep x) (format t (intl:gettext "~&It is a ~:[high (leading)~;low (trailing)~] surrogate character.") (surrogatep x :low)))) (defun describe-instance (x &optional (kind :structure)) (cond ((let ((so-class (kernel::find-class 'standard-object nil))) (and so-class (typep x so-class))) (fresh-line *standard-output*) (describe-object x *standard-output*)) (t (format t (intl:gettext "~&~S is a ~(~A~) of type ~A.") x kind (type-of x)) (dolist (slot (cddr (inspect::describe-parts x))) (format t "~%~A: ~S." (car slot) (cdr slot)))))) (defun describe-array (x) (let ((rank (array-rank x)) (element-type (array-element-type x))) (cond ((= rank 1) (format t (intl:gettext "~&~S is a ~:[~;displaced ~]vector of length ~D.") x (and (array-header-p x) (%array-displaced-p x)) (array-dimension x 0)) (if (array-has-fill-pointer-p x) (format t (intl:gettext "~&It has a fill pointer, currently ~d") (fill-pointer x)) (format t (intl:gettext "~&It has no fill pointer.")))) (t (format t (intl:gettext "~&~S is ~:[an~;a displaced~] array of rank ~A") x (%array-displaced-p x) rank) (format t (intl:gettext "~%Its dimensions are ~S.") (array-dimensions x)))) (unless (eq t element-type) (format t (intl:gettext "~&Its element type is specialized to ~S.") element-type)) (when (adjustable-array-p x) (format t (intl:gettext "~&It is adjustable."))) (when (static-array-p x) (format t (intl:gettext "~&It is static."))))) (defun describe-fixnum (x) (cond ((not (or *describe-verbose* (zerop *current-describe-level*)))) ((primep x) (format t (intl:gettext "~&It is a prime number."))) (t (format t (intl:gettext "~&It is a composite number."))))) #+double-double (defun describe-double-double-float (x) (format t (intl:gettext "~&~S is a ~S.") x (type-of x)) (format t (intl:gettext "~&Its components are ~S and ~S.") (kernel:double-double-hi x) (kernel:double-double-lo x))) (defun describe-hash-table (x) (format t (intl:gettext "~&~S is an ~A hash table.") x (hash-table-test x)) (format t (intl:gettext "~&Its size is ~D buckets.") (length (hash-table-table x))) (format t (intl:gettext "~&Its rehash-size is ~S.") (hash-table-rehash-size x)) (format t (intl:gettext "~&Its rehash-threshold is ~S.") (hash-table-rehash-threshold x)) (format t (intl:gettext "~&It currently holds ~d entries.") (hash-table-number-entries x)) (when (hash-table-weak-p x) (format t (intl:gettext "~&It is weak ~A table.") (hash-table-weak-p x)))) (defun describe-package (x) (describe-instance x) (let* ((internal (package-internal-symbols x)) (internal-count (- (package-hashtable-size internal) (package-hashtable-free internal))) (external (package-external-symbols x)) (external-count (- (package-hashtable-size external) (package-hashtable-free external)))) (format t (intl:gettext "~&~d symbols total: ~d internal and ~d external.") (+ internal-count external-count) internal-count external-count))) ;;;; Function and symbol description (documentation): ;;; DESC-DOC prints the specified kind of documentation about the given Name. ;;; If Name is null, or not a valid name, then don't print anything. ;;; (defun desc-doc (name kind kind-doc) (when (and name (typep name '(or symbol cons))) (let ((doc (documentation name kind)) (domain (case kind (variable (info variable textdomain name)) (function (info function textdomain name)) (structure (info typed-structure textdomain name)) (type (info type textdomain name)) (setf (info setf textdomain name))))) (when doc (format t (intl:gettext "~&~@(~A documentation:~)~& ~A") (or kind-doc kind) (dgettext domain doc)))))) ;;; DESCRIBE-FUNCTION-NAME -- Internal ;;; ;;; Describe various stuff about the functional semantics attached to the ;;; specified Name. Type-Spec is the function type specifier extracted from ;;; the definition, or NIL if none. ;;; (defun describe-function-name (name type-spec) (let ((*print-level* nil) (*print-length* nil)) (multiple-value-bind (type where) (if (valid-function-name-p name) (values (type-specifier (info function type name)) (info function where-from name)) (values type-spec :defined)) (when (consp type) (format t (intl:gettext "~&Its ~(~A~) argument types are:~% ~S") where (second type)) (format t (intl:gettext "~&Its result type is:~% ~S") (third type))))) (let ((inlinep (info function inlinep name))) (when inlinep (format t (intl:gettext "~&It is currently declared ~(~A~);~ ~:[no~;~] expansion is available.") inlinep (info function inline-expansion name))))) ;;; DESCRIBE-FUNCTION-INTERPRETED -- Internal ;;; ;;; Interpreted function describing; handles both closure and non-closure ;;; functions. Instead of printing the compiled-from info, we print the ;;; definition. ;;; (defun describe-function-interpreted (x kind name) (multiple-value-bind (exp closure-p dname) (eval:interpreted-function-lambda-expression x) (let ((args (eval:interpreted-function-arglist x))) (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind) (cond ((not args) (write-string (intl:gettext " There are no arguments."))) (t (write-string " ") (indenting-further *standard-output* 2 (prin1 args))))) (let ((name (or name dname))) (desc-doc name 'function kind) (unless (eq kind :macro) (describe-function-name name (type-specifier (eval:interpreted-function-type x))))) (when closure-p (format t (intl:gettext "~&Its closure environment is:")) (indenting-further *standard-output* 2 (let ((clos (eval:interpreted-function-closure x))) (dotimes (i (length clos)) (format t "~&~D: ~S" i (svref clos i)))))) (format t (intl:gettext "~&Its definition is:~% ~S") exp))) ;;; PRINT-COMPILED-FROM -- Internal ;;; ;;; Print information from the debug-info about where X was compiled from. ;;; (defun print-compiled-from (code-obj) (let ((info (kernel:%code-debug-info code-obj))) (when info (let ((sources (c::debug-info-source info))) (format t (intl:gettext "~&On ~A it was compiled from:") (format-universal-time nil (c::debug-source-compiled (first sources)) :style :iso8601)) (dolist (source sources) (let ((name (c::debug-source-name source))) (ecase (c::debug-source-from source) (:file (format t (intl:gettext "~&~A~% Created: ") (namestring name)) (ext:format-universal-time t (c::debug-source-created source) :style :iso8601) (let ((comment (c::debug-source-comment source))) (when comment (format t (intl:gettext "~& Comment: ~A") comment)))) (:stream (format t "~&~S" name)) (:lisp (format t "~&~S" name))))))))) ;;; DESCRIBE-FUNCTION-COMPILED -- Internal ;;; ;;; Describe a compiled function. The closure case calls us to print the ;;; guts. ;;; (defun describe-function-compiled (x kind name) (let ((args (%function-arglist x))) (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind) (cond ((not args) (format t (intl:gettext " There is no argument information available."))) ((string= args "()") (write-string (intl:gettext " There are no arguments."))) (t (write-string " ") (indenting-further *standard-output* 2 (write-string args))))) (let ((name (or name (%function-name x)))) (desc-doc name 'function kind) (unless (eq kind :macro) (describe-function-name name (%function-type x)))) (print-compiled-from (kernel:function-code-header x))) (defun describe-function-byte-compiled (x kind name) (let ((name (or name (c::byte-function-name x)))) (desc-doc name 'function kind) (unless (eq kind :macro) (describe-function-name name 'function))) (print-compiled-from (c::byte-function-component x))) ;;; DESCRIBE-FUNCTION -- Internal ;;; ;;; Describe a function with the specified kind and name. The latter ;;; arguments provide some information about where the function came from. Kind ;;; NIL means not from a name. ;;; (defun describe-function (x &optional (kind nil) name) (declare (type function x) (type (member :macro :function nil) kind)) (fresh-line) (ecase kind (:macro (format t (intl:gettext "Macro-function: ~S") x)) (:function (format t (intl:gettext "Function: ~S") x)) ((nil) (format t (intl:gettext "~S is a function.") x))) (case (get-type x) (#.vm:closure-header-type (describe-function-compiled (%closure-function x) kind name) (format t (intl:gettext "~&Its closure environment is:")) (indenting-further *standard-output* 8) (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset))) (format t "~&~D: ~S" i (%closure-index-ref x i)))) ((#.vm:function-header-type #.vm:closure-function-header-type) (describe-function-compiled x kind name)) (#.vm:funcallable-instance-header-type (typecase x (kernel:byte-function (describe-function-byte-compiled x kind name)) (kernel:byte-closure (describe-function-byte-compiled (byte-closure-function x) kind name) (format t (intl:gettext "~&Its closure environment is:")) (indenting-further *standard-output* 8) (let ((data (byte-closure-data x))) (dotimes (i (length data)) (format t "~&~D: ~S" i (svref data i))))) (eval:interpreted-function (describe-function-interpreted x kind name)) (t (describe-instance x :funcallable-instance)))) (t (format t (intl:gettext "~&It is an unknown type of function."))))) (defun describe-symbol (x) (let ((package (symbol-package x))) (if package (multiple-value-bind (symbol status) (find-symbol (symbol-name x) package) (declare (ignore symbol)) (format t (intl:gettext "~&~A is an ~A symbol in the ~A package.") x (string-downcase (symbol-name status)) (package-name (symbol-package x)))) (format t (intl:gettext "~&~A is an uninterned symbol.") x))) ;; ;; Describe the value cell. (let* ((kind (info variable kind x)) (wot (ecase kind (:special (intl:gettext "special variable")) (:constant (intl:gettext "constant")) (:global (intl:gettext "undefined variable")) (:macro (intl:gettext "symbol macro")) (:alien nil)))) (cond ((eq kind :alien) (let ((info (info variable alien-info x))) (format t (intl:gettext "~&~@~%") (sap-int (eval (alien::heap-alien-info-sap-form info))) (alien-internals:unparse-alien-type (alien::heap-alien-info-type info))) (format t (intl:gettext "~@") (eval x)))) ((eq kind :macro) (let ((expansion (info variable macro-expansion x))) (format t (intl:gettext "~&It is a ~A with expansion: ~S.") wot expansion))) ((boundp x) (let ((value (symbol-value x))) (format t (intl:gettext "~&It is a ~A; its value is ~S.") wot value) (describe value))) ((not (eq kind :global)) (format t (intl:gettext "~&It is a ~A; no current value.") wot))) (when (eq (info variable where-from x) :declared) (format t (intl:gettext "~&Its declared type is ~S.") (type-specifier (info variable type x)))) (desc-doc x 'variable kind)) ;; ;; Describe the function cell. (cond ((macro-function x) (describe-function (macro-function x) :macro x)) ((special-operator-p x) (desc-doc x 'function (intl:gettext "Special form"))) ((fboundp x) (describe-function (fdefinition x) :function x))) ;; ;; Print other documentation. (desc-doc x 'structure (intl:gettext "Structure")) (desc-doc x 'type (intl:gettext "Type")) (desc-doc x 'setf (intl:gettext "Setf macro")) (dolist (assoc (info random-documentation stuff x)) (format t (intl:gettext "~&Documentation on the ~(~A~):~%~A") (car assoc) (cdr assoc))) ;; ;; Print Class information (let ((class (kernel::find-class x nil))) (when class (format t (intl:gettext "~&It names a class ~A.") class) (describe class) (let ((pcl-class (%class-pcl-class class))) (when pcl-class (format t (intl:gettext "~&It names a PCL class ~A.") pcl-class) (describe pcl-class))))) ;; ;; Print out information about any types named by the symbol (when (eq (info type kind x) :defined) (format t (intl:gettext "~&It names a type specifier."))) ;; ;; Print out properties, possibly ignoring implementation details. (do ((plist (symbol-plist X) (cddr plist))) ((null plist) ()) (unless (member (car plist) *implementation-properties*) (format t (intl:gettext "~&Its ~S property is ~S.") (car plist) (cadr plist)) (describe (cadr plist)))) ;; Describe where it was defined. (let ((locn (info :source-location :defvar x))) (when locn (format t (intl:gettext "~&It is defined in:~&~A") (c::file-source-location-pathname locn))))) cmucl-21a/src/code/dfixnum.lisp000066400000000000000000000153251260377556400166330ustar00rootroot00000000000000;;; -*- Package: dfixnum -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project ;;; and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/dfixnum.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; ;;; Description: A skeleton of a package to do consing-free arithmetic on ;;; integers using two fixnums. One bit in each fixnum is used for internal ;;; calculations, so a 32-bit Lisp implementation with two-bit tags will ;;; have 56 bit range in this package (54 bits unsigned). ;;; ;;; NOTE: this package is extremly raw and only supports what is needed for ;;; the profiler. It should be considered an interface specification with ;;; a partial sketchy implentation. ;;; ;;; Author: Martin Cracauer ;;; ;;; Compatibility: Runs in any valid Common Lisp. (intl:textdomain "cmucl") (defpackage "DFIXNUM" (:export ;; types dfixnum dfparttype ;; constructing make-dfixnum dfixnum-make-from-number ;; arthmetic with our datatypes dfixnum-inc-df dfixnum-inc-hf dfixnum-set-df dfixnum-dec-df dfixnum-dec-hf ;; operations with normal datatypes dfixnum-set-from-number dfixnum-inc-integer dfixnum-set-single-float dfixnum-inc-single-float dfixnum-integer dfixnum-single-float dfixnum-single-float dfixnum-single-float-inline ;; operations on pairs instead of the dfixnum struct dfixnum-set-pair dfixnum-inc-pair dfixnum-pair-integer dfixnum-dec-pair dfixnum-copy-pair)) (in-package "DFIXNUM") (defconstant dfbits #.(- (integer-length most-positive-fixnum) 1)) (defconstant dfmax #.(expt 2 dfbits)) (deftype dfparttype () `(integer 0 ,#.(expt 2 dfbits))) (defstruct dfixnum (h 0 :type dfparttype) (l 0 :type dfparttype)) (defun dfixnum-inc-df (v i) "increments dfixnum v by dfixnum i" (declare (type dfixnum v) (type dfixnum i)) (let ((low (+ (dfixnum-l v) (dfixnum-l i)))) (if (> low dfmax) (progn (setf (dfixnum-l v) (- low dfmax)) (incf (dfixnum-h v))) (setf (dfixnum-l v) low))) (let ((high (+ (dfixnum-h v) (dfixnum-h i)))) (when (> high dfmax) (error (intl:gettext "dfixnum became too big ~a + ~a") v i)) (setf (dfixnum-h v) high)) v) (defun dfixnum-set-df (v i) (declare (type dfixnum v) (type dfixnum i)) (setf (dfixnum-h v) (dfixnum-h i)) (setf (dfixnum-l v) (dfixnum-l i))) (defun dfixnum-inc-hf (v i) "increments dfixnum v by i (max half fixnum)" (declare (type dfixnum v) (type fixnum i)) (when (> i dfmax) (error (intl:gettext "not a half-fixnum: ~a") i)) (let ((low (+ (dfixnum-l v) i))) (if (> low dfmax) (progn (setf (dfixnum-l v) (- low dfmax)) (incf (dfixnum-h v))) (setf (dfixnum-l v) (the dfparttype low)))) (when (> (+ (dfixnum-h v) i) dfmax) (error (intl:gettext "dfixnum became too big ~a + ~a") v i)) v) (defun dfixnum-dec-df (v i) "decrement dfixnum v by dfixnum i" (declare (type dfixnum v) (type dfixnum i)) (let ((low (- (dfixnum-l v) (dfixnum-l i))) (high (- (dfixnum-h v) (dfixnum-h i)))) (declare (type fixnum low high)) (when (< low 0) (decf high) (setf low (+ low dfmax))) (when (< high 0) (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high)) (setf (dfixnum-h v) high) (setf (dfixnum-l v) low)) v) (defun dfixnum-dec-hf (v i) "decrement dfixnum v by half-fixnum i" (declare (type dfixnum v) (type (integer 0 #.dfmax) i)) (let ((low (- (dfixnum-l v) i)) (high (dfixnum-h v))) (declare (type fixnum low high)) (when (< low 0) (decf high) (setf low (+ low dfmax))) (when (< high 0) (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high)) (setf (dfixnum-h v) high) (setf (dfixnum-l v) low)) v) (defun dfixnum-inc-integer (df i) "increments dfixnum by an interger which may be bigger than fixnum. May cons" (declare (type dfixnum df) (integer i) (optimize (ext:inhibit-warnings 3))) (let ((carry (+ (dfixnum-l df) (mod i dfmax)))) (setf (dfixnum-l df) (mod carry dfmax)) (if (> carry dfmax) (setf carry 1) (setf carry 0)) (setf (dfixnum-h df) (+ (dfixnum-h df) (ash i (- dfbits)) carry)))) (defun dfixnum-set-from-number (df i) (declare (type dfixnum df) (optimize (ext:inhibit-warnings 3))) (setf (dfixnum-h df) (ash i (- dfbits))) (setf (dfixnum-l df) (mod i dfmax))) (defun dfixnum-make-from-number (i) "returns a new dfixnum from number i" (declare (type number i) (optimize (ext:inhibit-warnings 3))) (let ((df (make-dfixnum))) (declare (type dfixnum df)) (dfixnum-set-from-number df i) df)) (defun dfixnum-integer (df) (declare (optimize (ext:inhibit-warnings 3))) (+ (* (dfixnum-h df) dfmax) (dfixnum-l df))) (defun dfixnum-single-float (df) (declare (optimize (ext:inhibit-warnings 3))) (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float)) (coerce (dfixnum-l df) 'single-float))) (defun dfixnum-single-float-inline (df) (declare (optimize (ext:inhibit-warnings 3))) (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float)) (coerce (dfixnum-l df) 'single-float))) (declaim (inline dfixnum-single-float-inline)) (defmacro dfixnum-set-single-float (float df) `(progn (setf ,float (+ (* (coerce (dfixnum-h ,df) 'single-float) ,#.(coerce dfmax 'single-float)) (coerce (dfixnum-l ,df) 'single-float))))) (defmacro dfixnum-inc-single-float (float df) `(progn (setf ,float (+ ,float (* (coerce (dfixnum-h ,df) 'single-float) ,#.(coerce dfmax 'single-float)) (coerce (dfixnum-l ,df) 'single-float))))) (defmacro dfixnum-set-pair (h l dfnum) `(progn (setf ,h (dfixnum-h ,dfnum)) (setf ,l (dfixnum-l ,dfnum)))) (defmacro dfixnum-inc-pair (vh vl ih il) "increments a pair of halffixnums by another pair" `(progn (let ((low (+ ,vl ,il))) (if (> low dfmax) (progn (setf ,vl (- low dfmax)) (incf ,vh)) (setf ,vl low))) (let ((high (+ ,vh ,ih))) (when (> high dfmax) (error (intl:gettext "dfixnum became too big ~a/~a + ~a/~a") ,vh ,vl ,ih ,il)) (setf ,vh high)))) (defun dfixnum-pair-integer (h l) (+ (* h dfmax) l)) (defmacro dfixnum-dec-pair (vh vl ih il) "decrement dfixnum pair by another pair" `(let ((low (- ,vl ,il)) (high (- ,vh ,ih))) (declare (type fixnum low high)) (when (< low 0) (decf high) (setf low (+ low dfmax))) (when (< high 0) (error (intl:gettext "dfixnum became negative ~a/~a - ~a/~a(~a/~a)") ,vh ,vl ,ih ,il low high)) (setf ,vh high) (setf ,vl low))) (defmacro dfixnum-copy-pair (vh vl ih il) `(progn (setf ,vh ,ih) (setf ,vl ,il))) cmucl-21a/src/code/dyncount.lisp000066400000000000000000000526631260377556400170320ustar00rootroot00000000000000;;; -*- Package: C; Log: C.Log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/dyncount.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Runtime support for dynamic VOP statistics collection. ;;; (in-package "C") (intl:textdomain "cmucl") #| Put *count-adjustments* back into VOP costs, and verify them. Make sure multi-cycle instruction costs are plausible. VOP classification. Make tables of %cost for benchmark X class. Could be represented as a sort of bar chart. |# (eval-when (compile) (when *collect-dynamic-statistics* (error "Compiling this file with dynamic stat collection turned on would ~ be a very bad idea."))) ;;;; Hash utilities: (defun make-hash-table-like (table) "Make a hash-table with the same test as table." (declare (type hash-table table)) (make-hash-table :test (lisp::hash-table-kind table))) (defun hash-difference (table1 table2) "Return a hash-table containing only the entries in Table1 whose key is not also a key in Table2." (declare (type hash-table table1 table2)) (let ((res (make-hash-table-like table1))) (do-hash (k v table1) (unless (nth-value 1 (gethash k table2)) (setf (gethash k res) v))) res)) (defun hash-list (table) "Return a list of the values in Table." (declare (type hash-table table)) (collect ((res)) (do-hash (k v table) (declare (ignore k)) (res v)) (res))) ;;; READ-HASH-TABLE, WRITE-HASH-TABLE -- Public ;;; ;;; Read (or write) a hash table from (or to) a file. ;;; (defun read-hash-table (file) (with-open-file (s file :direction :input) (dotimes (i 3) (format t "~%; ~A" (read-line s))) (let* ((eof '(nil)) (test (read s)) (reader (read s)) (res (make-hash-table :test test))) (read s); Discard writer... (loop (let ((key (read s nil eof))) (when (eq key eof) (return)) (setf (gethash key res) (funcall reader s key)))) res))) ;;; (defun write-hash-table (table file &key (comment (format nil "Contents of ~S" table)) (reader 'read) (writer 'prin1) (test 'equal)) (with-open-file (s file :direction :output :if-exists :rename-and-delete) (with-standard-io-syntax (let ((*print-readably* nil)) (format s "~A~%Version ~A on ~A~%" comment (lisp-implementation-version) (machine-instance)) (format-universal-time s (get-universal-time)) (terpri s) (format s "~S ~S ~S~%" test reader writer) (do-hash (k v table) (prin1 k s) (write-char #\space s) (funcall writer v s) (terpri s))))) table) ;;;; Info accumulation: ;;; Used to accumulate info about the usage of a single VOP. Cost and count ;;; are kept as double-floats, which lets us get more bits and avoid annoying ;;; overflows. ;;; (deftype count-vector () '(simple-array double-float (2))) ;;; (defstruct (vop-stats (:constructor %make-vop-stats (name)) (:constructor make-vop-stats-key)) (name (required-argument) :type simple-string) (data (make-array 2 :element-type 'double-float) :type count-vector)) (defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0)) (defmacro vop-stats-cost (x) `(aref (vop-stats-data ,x) 1)) (defun make-vop-stats (&key name count cost) (let ((res (%make-vop-stats name))) (setf (vop-stats-count res) count) (setf (vop-stats-cost res) cost) res)) (declaim (freeze-type dyncount-info vop-stats)) ;;; NOTE-DYNCOUNT-INFO -- Internal ;;; ;;; Add the Info into the cumulative result on the VOP name plist. We use ;;; plists so that we will touch minimal system code outside of this file ;;; (which may be compiled with profiling on.) ;;; (defun note-dyncount-info (info) (declare (type dyncount-info info) (inline get %put) (optimize (speed 2))) (let ((counts (dyncount-info-counts info)) (vops (dyncount-info-vops info))) (dotimes (index (length counts)) (declare (type index index)) (let ((count (coerce (the (unsigned-byte 31) (aref counts index)) 'double-float))) (when (minusp count) (warn "Oops: overflow.") (return-from note-dyncount-info nil)) (unless (zerop count) (let* ((vop-info (svref vops index)) (length (length vop-info))) (declare (simple-vector vop-info)) (do ((i 0 (+ i 4))) ((>= i length)) (declare (type index i)) (let* ((name (svref vop-info i)) (entry (or (get name 'vop-stats) (setf (get name 'vop-stats) (%make-vop-stats (symbol-name name)))))) (incf (vop-stats-count entry) (* (coerce (the index (svref vop-info (1+ i))) 'double-float) count)) (incf (vop-stats-cost entry) (* (coerce (the index (svref vop-info (+ i 2))) 'double-float) count)))))))))) (defun clear-dyncount-info (info) (declare (type dyncount-info info)) (declare (optimize (speed 3) (safety 0))) (let ((counts (dyncount-info-counts info))) (dotimes (i (length counts)) (setf (aref counts i) 0)))) ;;; CLEAR-VOP-COUNTS -- Public ;;; ;;; Clear any VOP-COUNTS properties and the counts vectors for all code ;;; objects. The latter loop must not call any random functions. ;;; (defun clear-vop-counts (&optional (spaces '(:dynamic))) "Clear all dynamic VOP counts for code objects in the specified spaces." (do-hash (k v (backend-template-names *backend*)) (declare (ignore v)) (remprop k 'vop-stats)) (locally (declare (optimize (speed 3) (safety 0)) (inline vm::map-allocated-objects)) (without-gcing (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (dyncount-info-p object) (clear-dyncount-info object))) space))))) ;;; GET-VOP-COUNTS -- Public ;;; ;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the ;;; specified spaces. Return a hash table describing the counts. The initial ;;; loop must avoid calling any functions outside this file to prevent adding ;;; noise to the data, since other files may be compiled with profiling. ;;; (defun get-vop-counts (&optional (spaces '(:dynamic)) &key (clear nil)) "Return a hash-table mapping string VOP names to VOP-STATS structures describing the VOPs executed. If clear is true, then reset all counts to zero as a side-effect." (locally (declare (optimize (speed 3) (safety 0)) (inline vm::map-allocated-objects)) (without-gcing (dolist (space spaces) (vm::map-allocated-objects #'(lambda (object type-code size) (declare (ignore type-code size)) (when (dyncount-info-p object) (note-dyncount-info object) (when clear (clear-dyncount-info object)))) space)))) (let ((counts (make-hash-table :test #'equal))) (do-hash (k v (backend-template-names *backend*)) (declare (ignore v)) (let ((stats (get k 'vop-stats))) (when stats (setf (gethash (symbol-name k) counts) stats) (when clear (remprop k 'vop-stats))))) counts)) ;;; FIND-INFO-FOR -- Interface ;;; ;;; Return the DYNCOUNT-INFO for FUNCTION. ;;; (defun find-info-for (function) (declare (type function function)) (let* ((function (%primitive closure-function function)) (component (di::function-code-header function))) (do ((end (get-header-data component)) (i vm:code-constants-offset (1+ i))) ((= end i)) (let ((constant (code-header-ref component i))) (when (dyncount-info-p constant) (return constant)))))) (defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space) "Apply Function to Args, collecting dynamic statistics on the running. Spaces are the spaces to scan for counts. If By-Space is true, we return a list of result tables, instead of a single table. In this case, specify :READ-ONLY first." (clear-vop-counts spaces) (apply function args) (if by-space (mapcar #'(lambda (space) (get-vop-counts (list space) :clear t)) spaces) (get-vop-counts spaces))) ;;;; Adjustments: #| (defparameter *count-adjustments* '((return-multiple 152) (tail-call-variable 88) (unwind 92) (throw 116) (allocate-vector 72) (sxhash-simple-string 248) (sxhash-simple-substring 264) (copy-to-system-area 1200) (copy-from-system-area 1200) (system-area-copy 1204) (bit-bash-copy 1412) (vm::generic-+ 72) (vm::generic-- 72) (vm::generic-* 184) (vm::generic-< 68) (vm::generic-> 68) (vm::generic-eql 80) (vm::generic-= 80) (vm::generic-/= 104) (%make-weak-pointer 60) (make-value-cell 56) (vm::make-funcallable-instance 76) (make-closure 76) (make-complex 60) (make-ratio 60) (%allocate-bignum 72) (make-structure 72) (cons 50))) |# ;;; GET-VOP-COSTS -- Public ;;; (defun get-vop-costs () "Return a hash-table mapping string VOP names to the cost recorded in the generator for all VOPs which are also the names of assembly routines." (let ((res (make-hash-table :test #'equal))) (do-hash (name v lisp::*assembler-routines*) (declare (ignore v)) (let ((vop (gethash name (backend-template-names *backend*)))) (when vop (setf (gethash (symbol-name name) res) (template-cost (template-or-lose name)))))) res)) (defvar *native-costs* (get-vop-costs) "Costs of assember routines on this machine.") ;;;; Classification: (defparameter *basic-classes* '(("Integer multiplication" "*/FIXNUM" "*/SIGNED" "*/UNSIGNED" "SIGNED-*" "FIXNUM-*" "GENERIC-*") ("Integer division" "TRUNCATE") ("Generic arithmetic" "GENERIC" "TWO-ARG") ("Inline EQL" "EQL") ("Inline compare less/greater" "/" "<-C/" ">-C/") ("Inline arith" "*/" "//" "+/" "-/" "NEGATE" "ABS" "+-C" "--C") ("Inline logic" "-ASH" "$ASH" "LOG") ("CAR/CDR" "CAR" "CDR") ("Array type test" "ARRAYP" "VECTORP" "ARRAY-HEADER-P") ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP") ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE") ("Array bounds check" "CHECK-BOUND") ("Complex type check" "$CHECK-" "COERCE-TO-FUNCTION") ("Special read" "SYMBOL-VALUE") ("Special bind" "BIND$") ("Tagging" "MOVE-FROM") ("Untagging" "MOVE-TO" "MAKE-FIXNUM") ("Move" "MOVE") ("Non-local exit" "CATCH" "THROW" "DYNAMIC-STATE" "NLX" "UNWIND") ("Array write" "DATA-VECTOR-SET" "$SET-RAW-BITS$") ("Array read" "DATA-VECTOR-REF" "$RAW-BITS$" "VECTOR-LENGTH" "LENGTH/SIMPLE" "ARRAY-HEADER") ("List/string utility" "LENGTH/LIST" "SXHASH" "BIT-BASH" "$LENGTH$") ("Alien operations" "SAP" "ALLOC-NUMBER-STACK" "$CALL-OUT$") ("Function call/return" "CALL" "RETURN" "ALLOCATE-FRAME" "COPY-MORE-ARG" "LISTIFY-REST-ARG" "VERIFY-ARGUMENT-COUNT") ("Allocation" "MAKE-" "ALLOC" "$CONS$" "$LIST$" "$LIST*$") ("Float conversion" "%SINGLE-FLOAT" "%DOUBLE-FLOAT" "-BITS$") ("Complex type predicate" "P$"))) ;;; MATCHES-PATTERN -- Internal ;;; ;;; Return true if Name patches a specified pattern. Pattern is a string ;;; (or symbol) or a list of strings (or symbols). If any specified string ;;; appears as a substring of name, the pattern is matched. #\$'s are wrapped ;;; around name, allowing the use of $ to force a match at the beginning or ;;; end. ;;; (defun matches-pattern (name pattern) (declare (simple-string name)) (let ((name (concatenate 'string "$" name "$"))) (dolist (pat (if (listp pattern) pattern (list pattern)) nil) (when (search (the simple-string (string pat)) name :test #'char=) (return t))))) ;;; FIND-MATCHES, WHAT-CLASS -- Interface ;;; ;;; Utilities for debugging classification rules. FIND-MATCHES returns a ;;; list of all the VOP names in Table that match Pattern. WHAT-CLASS returns ;;; the class that NAME would be placed in. ;;; (defun find-matches (table pattern) (collect ((res)) (do-hash (key value table) (declare (ignore value)) (when (matches-pattern key pattern) (res key))) (res))) ;;; (defun what-class (name classes) (dolist (class classes nil) (when (matches-pattern name (rest class)) (return (first class))))) ;;; CLASSIFY-COSTS -- Interface ;;; ;;; Given a VOP-STATS hash-table, return a new one with VOPs in the same ;;; class merged into a single entry for that class. The classes are ;;; represented as a list of lists: (class-name pattern*). Each pattern is a ;;; string (or symbol) that can appear as a subsequence of the VOP name. A VOP ;;; is placed in the first class that it matches, or is left alone if it ;;; matches no class. ;;; (defun classify-costs (table classes) (let ((res (make-hash-table-like table))) (do-hash (key value table) (let ((class (dolist (class classes nil) (when (matches-pattern key (rest class)) (return (first class)))))) (if class (let ((found (or (gethash class res) (setf (gethash class res) (%make-vop-stats class))))) (incf (vop-stats-count found) (vop-stats-count value)) (incf (vop-stats-cost found) (vop-stats-cost value))) (setf (gethash key res) value)))) res)) ;;;; Analysis: ;;; COST-SUMMARY -- Internal ;;; ;;; Sum the count and costs. ;;; (defun cost-summary (table) (let ((total-count 0d0) (total-cost 0d0)) (do-hash (k v table) (declare (ignore k)) (incf total-count (vop-stats-count v)) (incf total-cost (vop-stats-cost v))) (values total-count total-cost))) ;;; COMPENSATE-COSTS -- Internal ;;; ;;; Return a hash table of DYNCOUNT-INFO structures, with cost adjustments ;;; according to the Costs table. Any VOPs in the list IGNORE are ignored. ;;; (defun compensate-costs (table costs &optional ignore) (let ((res (make-hash-table-like table))) (do-hash (key value table) (unless (or (string= key "COUNT-ME") (member key ignore :test #'string=)) (let ((cost (gethash key costs))) (if cost (let* ((count (vop-stats-count value)) (sum (+ (* cost count) (vop-stats-cost value)))) (setf (gethash key res) (make-vop-stats :name key :count count :cost sum))) (setf (gethash key res) value))))) res)) ;;; COMPARE-STATS -- Internal ;;; ;;; Take two tables of vop-stats and return a table of entries where the ;;; entries have been compared. The counts are normalized to Compared. The ;;; costs are the difference of the costs adjusted by the difference in counts: ;;; the cost for Original is modified to correspond to the count in Compared. ;;; (defun compare-stats (original compared) (declare (type hash-table original compared)) (let ((res (make-hash-table-like original))) (do-hash (k cv compared) (let ((ov (gethash k original))) (when ov (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv)))) (setf (gethash k res) (make-vop-stats :name k :count norm-cnt :cost (- (/ (vop-stats-cost ov) norm-cnt) (vop-stats-cost cv)))))))) res)) ;;; COMBINE-STATS -- Public ;;; (defun combine-stats (&rest tables) "Sum the VOP stats for the specified tables, returning a new table with the combined results." (let ((res (make-hash-table-like (first tables)))) (dolist (table tables) (do-hash (k v table) (let ((found (or (gethash k res) (setf (gethash k res) (%make-vop-stats k))))) (incf (vop-stats-count found) (vop-stats-count v)) (incf (vop-stats-cost found) (vop-stats-cost v))))) res)) ;;;; Report generation: ;;; SORT-RESULT -- Internal ;;; (defun sort-result (table by) (sort (hash-list table) #'> :key #'(lambda (x) (abs (ecase by (:count (vop-stats-count x)) (:cost (vop-stats-cost x))))))) ;;; ENTRY-REPORT -- Internal ;;; ;;; Report about VOPs in the list of stats structures. ;;; (defun entry-report (entries cut-off compensated compare total-cost) (let ((counter (if (and cut-off (> (length entries) cut-off)) cut-off most-positive-fixnum))) (dolist (entry entries) (let* ((cost (vop-stats-cost entry)) (name (vop-stats-name entry)) (entry-count (vop-stats-count entry)) (comp-entry (if compare (gethash name compare) entry)) (count (vop-stats-count comp-entry))) (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F ~5,2,2F%~%" (vop-stats-name entry) compare (if compare entry-count (round entry-count)) (/ cost count) (/ (if compare (- (vop-stats-cost (gethash name compensated)) (vop-stats-cost comp-entry)) cost) total-cost)) (when (zerop (decf counter)) (format t "[End of top ~D]~%" cut-off)))))) ;;; FIND-CUT-OFF -- Internal ;;; ;;; Divide Sorted into two lists, the first cut-off elements long. Any VOP ;;; names that match one of the report strings are moved into the report list ;;; even if they would otherwise fall below the cut-off. ;;; (defun find-cut-off (sorted cut-off report) (if (or (not cut-off) (<= (length sorted) cut-off)) (values sorted ()) (let ((not-cut (subseq sorted 0 cut-off))) (collect ((select) (reject)) (dolist (el (nthcdr cut-off sorted)) (let ((name (vop-stats-name el))) (if (matches-pattern name report) (select el) (reject el)))) (values (append not-cut (select)) (reject)))))) ;;; CUT-OFF-REPORT -- Internal ;;; ;;; Display information about entries that were not displayed due to the ;;; cut-off. Note: if compare, we find the total cost delta and the geometric ;; mean of the normalized counts. ;; (defun cut-off-report (other compare total-cost) (let ((rest-cost 0d0) (rest-count 0d0) (rest-entry-count (if compare 1d0 0d0))) (dolist (entry other) (incf rest-cost (vop-stats-cost entry)) (incf rest-count (vop-stats-count (if compare (gethash (vop-stats-name entry) compare) entry))) (if compare (setq rest-entry-count (* rest-entry-count (vop-stats-count entry))) (incf rest-entry-count (vop-stats-count entry)))) (let ((count (if compare (expt rest-entry-count (/ (coerce (length other) 'double-float))) (round rest-entry-count)))) (format t "~30: ~:[~13:D~;~13,2F~] ~9,2F ~@[~5,2,2F%~]~%" compare count (/ rest-cost rest-count) (unless compare (/ rest-cost total-cost)))))) ;;; COMPARE-REPORT -- Internal ;;; ;;; Report summary information about the difference between the comparison ;;; and base data sets. ;;; (defun compare-report (total-count total-cost compare-total-count compare-total-cost compensated compare) (format t "~30: ~13,2F ~9,2F~%" (/ total-count compare-total-count) (/ total-cost compare-total-cost)) (flet ((frob (a b sign wot) (multiple-value-bind (cost count) (cost-summary (hash-difference a b)) (unless (zerop count) (format t "~30<~A~>: ~13:D ~9,2F ~5,2,2F%~%" wot (* sign (round count)) (* sign (/ cost count)) (* sign (/ cost compare-total-cost))))))) (frob compensated compare 1 "Not in comparison") (frob compare compensated -1 "Only in comparison")) (format t "~30: ~13,2E ~9,2E~%" compare-total-count compare-total-cost)) ;;; The fraction of system time that we guess happened during GC. ;;; (defparameter *gc-system-fraction* 2/3) ;;; FIND-CPI -- Interface ;;; ;;; Estimate CPI from CPU time and cycles accounted in profiling ;;; information. ;;; (defun find-cpi (total-cost user system gc clock) (let ((adj-time (if (zerop gc) user (- user (- gc (* system *gc-system-fraction*)))))) (/ (* adj-time clock) total-cost))) ;;; GENERATE-REPORT -- Public ;;; ;;; Generate a report from the specified table. ;;; (defun generate-report (table &key (cut-off 15) (sort-by :cost) (costs *native-costs*) ((:compare uncomp-compare)) (compare-costs costs) ignore report (classes *basic-classes*) user (system 0d0) (gc 0d0) (clock 25d6)) (let* ((compensated (classify-costs (if costs (compensate-costs table costs ignore) table) classes)) (compare (when uncomp-compare (classify-costs (if compare-costs (compensate-costs uncomp-compare compare-costs ignore) uncomp-compare) classes))) (compared (if compare (compare-stats compensated compare) compensated)) (*gc-verbose* nil)) (multiple-value-bind (total-count total-cost) (cost-summary compensated) (multiple-value-bind (compare-total-count compare-total-cost) (when compare (cost-summary compare)) (format t "~2&~30 ~13 ~9 ~6:@~%") (let ((sorted (sort-result compared sort-by)) (base-total (if compare compare-total-cost total-cost))) (multiple-value-bind (report other) (find-cut-off sorted cut-off report) (entry-report report cut-off compensated compare base-total) (when other (cut-off-report other compare base-total)))) (when compare (compare-report total-count total-cost compare-total-count compare-total-cost compensated compare)) (format t "~30: ~13,2E ~9,2E~%" total-count total-cost) (when user (format t "~%Cycles per instruction = ~,2F~%" (find-cpi total-cost user system gc clock)))))) (values)) ;;; STATS-{READER,WRITER} -- Public ;;; ;;; Read & write VOP stats using hash IO utility. ;;; (defun stats-reader (stream key) (make-vop-stats :name key :count (read stream) :cost (read stream))) ;;; (defun stats-writer (object stream) (format stream "~S ~S" (vop-stats-count object) (vop-stats-cost object))) cmucl-21a/src/code/env-access.lisp000066400000000000000000000206011260377556400172010ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: C; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/env-access.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; The environment access functions specified in Common Lisp the ;;; Language, 2nd edition. ;;; (in-package "EXT") (intl:textdomain "cmucl") (export '(variable-information function-information declaration-information parse-macro)) (in-package "C") (defun variable-information (var &optional env) "Returns information about the symbol VAR in the lexical environment ENV. Three values are returned: 1) Type or binding of VAR. NIL No definition or binding :special VAR is special :lexical VAR is lexical :symbol-macro VAR refers to a SYMBOL-MACROLET binding :constant VAR refers to a named constant or VAR is a keyword 2) non-NIL if there is a local binding 3) An a-list containing information about any declarations that apply." (let* ((*lexical-environment* (or env (make-null-environment))) (info (lexenv-find var variables))) (etypecase info (leaf (let ((type (type-specifier (type-intersection (leaf-type info) (or (lexenv-find info type-restrictions) *universal-type*))))) (etypecase info (lambda-var (values :lexical t `((ignore . ,(lambda-var-ignorep info)) (type . ,type) (dynamic-extent . ,(lambda-var-dynamic-extent info))))) (global-var (values :special t `((type . ,type)) )) (constant (values :constant nil `((type . ,type)) ))))) (cons (values :symbol-macro t nil)) (null (values (ecase (info variable kind var) (:special :special) (:constant :constant) (:macro :symbol-macro) (:global nil)) nil `( (type . ,(type-specifier (info variable type var))))))))) (defun declaration-information (declaration-name &optional env) "Returns information about declarations named by the symbol DECLARATION-NAME. Supported DECLARATION-NAMES are 1) OPTIMIZE A list whose entries are of the form (QUALITY VALUE) is returned, where QUALITY and VALUE are standard optimization qualities and values. 2) EXT:OPTIMIZE-INTERFACE Like OPTIMIZE, but for the EXT:OPTIMIZE-INTERFACE declaration. 3) DECLARATION. A list of the declaration names the have been proclaimed as valid." (let ((lexenv (or env (make-null-environment)))) (case declaration-name (optimize (let ((cookie (lexenv-cookie lexenv))) (list (list 'speed (cookie-speed cookie)) (list 'safety (cookie-safety cookie)) (list 'compilation-speed (cookie-cspeed cookie)) (list 'space (cookie-space cookie)) (list 'debug (cookie-debug cookie)) (list 'inhibit-warnings (cookie-brevity cookie))) )) (ext:optimize-interface (let ((cookie (lexenv-interface-cookie lexenv))) (list (list 'speed (cookie-speed cookie)) (list 'safety (cookie-safety cookie)) (list 'compilation-speed (cookie-cspeed cookie)) (list 'space (cookie-space cookie)) (list 'debug (cookie-debug cookie)) (list 'inhibit-warnings (cookie-brevity cookie))))) (declaration (cond (env ;; What are we supposed to do if an environment is ;; given? nil) (t (let ((decls (list 'special 'ftype 'function 'inline 'notinline 'maybe-inline 'ignore 'ignorable 'optimize 'optimize-interface 'type 'values))) ;; Do we want to run over the entire list of ;; environments in *info-environment*? (dolist (env ext::*info-environment*) (do-info (env :name name :class class :type type :value value) (when (equal class "DECLARATION") (push name decls)))) decls)))) (t (error (intl:gettext "Unsupported declaration ~S.") declaration-name))))) (defun parse-macro (name lambda-list body &optional env) "Process a macro in the same way that DEFMACRO or MACROLET would. Three values are returned: 1) A lambda-expression that accepts two arguments 2) A form 3) An environment" (declare (ignore env)) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENVIRONMENT-"))) (multiple-value-bind (body decls) (lisp::parse-defmacro lambda-list whole body name 'parse-macro :environment environment) `(lambda (,whole ,environment) ,@decls ,body)))) (defun function-information (function &optional env) "Returns information about the function name FUNCTION in the lexical environment ENV. Three values are returned: 1) Type of definition or binding: NIL No apparent definition :function FUNCTION refers to a function :macro FUNCTION refers to a macro :special-form FUNCTION is a special form 2) non-NIL if definition is local 3) An a-list containing information about the declarations that apply." (flet ((inlinealist (i) (ecase i (:inline (list '(inline . inline))) (:notinline (list '(inline . notinline))) (:maybe-inline (list '(inline . maybe-inline))) ((nil) nil)))) (let* ((*lexical-environment* (or env (make-null-environment))) (info (lexenv-find-function function))) (etypecase info (clambda (let ((type (type-specifier (type-intersection (leaf-type info) (or (lexenv-find info type-restrictions) *universal-type*))))) (values :function t (nconc (if (functional-dynamic-extent info) (list '(dynamic-extent . t))) (inlinealist (functional-inlinep info)) (if (not (eq type 'function)) (list `(ftype . ,type))))))) (cons (values :macro t nil)) (null (multiple-value-bind (kind kindp) (info function kind function) (cond (kindp (ecase kind (:macro (values :macro nil nil)) (:special-form (values :special-form nil nil)) (:function (values :function nil (nconc (list `(ftype . ,(type-specifier (info function type function)))) (inlinealist (info function inlinep function))))))) (t (if (eq kind :function) (values :function nil (nconc (list `(ftype . ,(type-specifier (info function type function)))) (inlinealist (info function inlinep function)))) (values nil nil nil)))))) (defined-function (let ((type (type-specifier (type-intersection (defined-function-type info) (or (lexenv-find info type-restrictions) *universal-type*))))) (values :function nil (nconc (if (not (eq type 'function)) (list `(ftype . ,type))) (inlinealist (defined-function-inlinep info )))))))))) (defmacro env (&environment env) `(quote ,env)) (defun augment-environment (env &key variable symbol-macro function macro declare) "Return a new environment containing information in ENV that is augmented by the specified parameters: :VARIABLE a list of symbols visible as bound variables in the new environemnt :SYMBOL-MACRO a list of symbol macro definitions :FUNCTION a list of function names that will be visible as local functions :MACRO a list of local macro definitions :DECLARE a list of declaration specifiers" (when (or macro symbol-macro) (setq env (copy-structure env))) (when macro (setf (lexenv-functions env) (nconc (loop for (name def) in macro collect (cons name (cons 'sys::macro def))) (lexenv-functions env)))) (when symbol-macro (setf (lexenv-variables env) (nconc (loop for (name def) in symbol-macro collect (cons name (cons 'sys::macro def))) (lexenv-variables env)))) (if (not (or variable function declare)) env (handler-bind (((or style-warning) #'(lambda (c) (declare (ignore c)) (invoke-restart 'muffle-warning)))) (eval:internal-eval `(flet ,(loop for fn in function collect `(,fn ())) (let ,variable (declare ,@declare) (env))) t env)))) cmucl-21a/src/code/error.lisp000066400000000000000000001324761260377556400163210ustar00rootroot00000000000000;;; -*- Package: conditions; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/error.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This is a condition system for CMU Common Lisp. ;;; It was originally taken from some prototyping code written by KMP@Symbolics ;;; and massaged for our uses. ;;; (in-package "CONDITIONS") (use-package "EXTENSIONS") (use-package "KERNEL") (intl:textdomain "cmucl") (in-package "KERNEL") (export '(layout-invalid condition-function-name simple-control-error simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function constant-modified invalid-case #+stack-checking stack-overflow #+heap-overflow-check heap-overflow)) (in-package "LISP") (export '(break error warn cerror ;; ;; The following are found in macros.lisp: check-type assert etypecase ctypecase ecase ccase ;; ;; These are all the new things to export from "LISP" now that this ;; proposal has been accepted. *break-on-signals* *debugger-hook* signal handler-case handler-bind ignore-errors define-condition make-condition with-simple-restart with-condition-restarts restart-case restart-bind restart-name restart-name find-restart compute-restarts invoke-restart invoke-restart-interactively abort continue muffle-warning store-value use-value invoke-debugger restart condition warning style-warning serious-condition simple-condition simple-warning simple-error simple-condition-format-control simple-condition-format-arguments storage-condition type-error type-error-datum type-error-expected-type simple-type-error program-error parse-error control-error stream-error stream-error-stream end-of-file file-error file-error-pathname cell-error cell-error-name unbound-variable undefined-function arithmetic-error arithmetic-error-operation arithmetic-error-operands package-error package-error-package division-by-zero floating-point-overflow floating-point-underflow floating-point-inexact floating-point-invalid-operation #+x86 floating-point-denormal-operand)) (in-package "CONDITIONS") ;;;; Keyword utilities. (eval-when (eval compile load) (defun parse-keyword-pairs (list keys) (do ((l list (cddr l)) (k '() (list* (cadr l) (car l) k))) ((or (null l) (not (member (car l) keys))) (values (nreverse k) l)))) (defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms) (let ((temp (member '&rest names))) (unless (= (length temp) 2) (simple-program-error (intl:gettext "&rest keyword is ~:[missing~;misplaced~].") temp)) (let ((key-vars (ldiff names temp)) (key-var (or keywords-var (gensym))) (rest-var (cadr temp))) (let ((keywords (mapcar #'(lambda (x) (intern (string x) ext:*keyword-package*)) key-vars))) `(multiple-value-bind (,key-var ,rest-var) (parse-keyword-pairs ,expression ',keywords) (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword))) key-vars keywords) ,@forms)))))) ) ;eval-when ;;;; Restarts. ;;; A list of lists of restarts. ;;; (defvar *restart-clusters* '()) ;;; An ALIST (condition . restarts) which records the restarts currently ;;; associated with Condition. ;;; (defvar *condition-restarts* ()) (defun compute-restarts (&optional condition) "Return a list of all the currently active restarts ordered from most recently established to less recently established. If Condition is specified, then only restarts associated with Condition (or with no condition) will be returned." (let ((associated ()) (other ())) (dolist (alist *condition-restarts*) (if (eq (car alist) condition) (setq associated (cdr alist)) (setq other (append (cdr alist) other)))) (collect ((res)) (dolist (restart-cluster *restart-clusters*) (dolist (restart restart-cluster) (when (and (or (not condition) (member restart associated) (not (member restart other))) (funcall (restart-test-function restart) condition)) (res restart)))) (res)))) (defun restart-print (restart stream depth) (declare (ignore depth)) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t)) (restart-report restart stream))) (defstruct (restart (:print-function restart-print)) name function report-function interactive-function (test-function #'(lambda (cond) (declare (ignore cond)) t))) (setf (documentation 'restart-name 'function) _N"Returns the name of the given restart object.") (defun restart-report (restart stream) (funcall (or (restart-report-function restart) (let ((name (restart-name restart))) #'(lambda (stream) (if name (format stream "~S" name) (format stream "~S" restart))))) stream)) (defmacro with-condition-restarts (condition-form restarts-form &body body) "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* Evaluates the Forms in a dynamic environment where the restarts in the list Restarts-Form are associated with the condition returned by Condition-Form. This allows FIND-RESTART, etc., to recognize restarts that are not related to the error currently being debugged. See also RESTART-CASE." (let ((n-cond (gensym))) `(let ((*condition-restarts* (cons (let ((,n-cond ,condition-form)) (cons ,n-cond (append ,restarts-form (cdr (assoc ,n-cond *condition-restarts*))))) *condition-restarts*))) ,@body))) (defmacro restart-bind (bindings &body forms) "Executes forms in a dynamic context where the given restart bindings are in effect. Users probably want to use RESTART-CASE. When clauses contain the same restart name, FIND-RESTART will find the first such clause." `(let ((*restart-clusters* (cons (list ,@(mapcar #'(lambda (binding) (unless (or (car binding) (member :report-function binding :test #'eq)) (warn (intl:gettext "Unnamed restart does not have a ~ report function -- ~S") binding)) `(make-restart :name ',(car binding) :function ,(cadr binding) ,@(cddr binding))) bindings)) *restart-clusters*))) ,@forms)) (defun find-restart (name &optional condition) "Returns the first restart named name. If name is a restart, it is returned if it is currently active. If no such restart is found, nil is returned. It is an error to supply nil as a name. If Condition is specified and not NIL, then only restarts associated with that condition (or with no condition) will be returned." (find-if #'(lambda (x) (or (eq x name) (eq (restart-name x) name))) (compute-restarts condition))) (defun invoke-restart (restart &rest values) "Calls the function associated with the given restart, passing any given arguments. If the argument restart is not a restart or a currently active non-nil restart name, then a control-error is signalled." (let ((real-restart (find-restart restart))) (unless real-restart (error 'simple-control-error :format-control (intl:gettext "Restart ~S is not active.") :format-arguments (list restart))) (apply (restart-function real-restart) values))) (defun invoke-restart-interactively (restart) "Calls the function associated with the given restart, prompting for any necessary arguments. If the argument restart is not a restart or a currently active non-nil restart name, then a control-error is signalled." (let ((real-restart (find-restart restart))) (unless real-restart (error 'simple-control-error :format-control (intl:gettext "Restart ~S is not active.") :format-arguments (list restart))) (%invoke-restart-interactively real-restart))) ;;; ;;; Like Invoke-Restart-Interactively, but don't check if the restart ;;; is currently active. Used by the debugger. ;;; (defun %invoke-restart-interactively (restart) (apply (restart-function restart) (let ((interactive-function (restart-interactive-function restart))) (if interactive-function (funcall interactive-function) '())))) (eval-when (compile load eval) ;;; ;;; Return a list of restarts with names NAMES, taking duplicate ;;; names into account. ;;; (defun %find-restarts (names) (let ((all (compute-restarts))) (collect ((restarts)) (dolist (name names (restarts)) (let ((restart (find-if (lambda (x) (or (eq x name) (eq (restart-name x) name))) all))) (restarts restart) (setq all (delete restart all))))))) ;;; Wrap the restart-case expression in a with-condition-restarts if ;;; appropriate. Gross, but it's what the book seems to say... ;;; (defun munge-restart-case-expression (expression data env) (let ((exp (macroexpand expression env))) (if (consp exp) (let* ((name (car exp)) (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) (if (member name '(signal error cerror warn)) (once-only ((n-cond `(coerce-to-condition ,(first args) (list ,@(rest args)) ',(case name (warn 'simple-warning) (signal 'simple-condition) (t 'simple-error)) ',name))) `(with-condition-restarts ,n-cond (%find-restarts ',(mapcar (lambda (x) (nth 0 x)) data)) ,(if (eq name 'cerror) `(cerror ,(second expression) ,n-cond) `(,name ,n-cond)))) expression)) expression))) ); eval-when (compile load eval) (defmacro restart-case (expression &body clauses &environment env) "(RESTART-CASE form {(case-name arg-list {keyword value}* body)}*) The form is evaluated in a dynamic context where the clauses have special meanings as points to which control may be transferred (see INVOKE-RESTART). When clauses contain the same case-name, FIND-RESTART will find the first such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or macroexpands into such) then the signalled condition will be associated with the new restarts." (flet ((transform-keywords (&key report interactive test) (let ((result '())) (when report (setq result (list* (if (stringp report) `#'(lambda (stream) (write-string ,report stream)) `#',report) :report-function result))) (when interactive (setq result (list* `#',interactive :interactive-function result))) (when test (setq result (list* `#',test :test-function result))) (nreverse result)))) (let ((block-tag (gensym)) (temp-var (gensym)) (data (mapcar #'(lambda (clause) (with-keyword-pairs ((report interactive test &rest forms) (cddr clause)) (list (car clause) ;name=0 (gensym) ;tag=1 (transform-keywords :report report ;keywords=2 :interactive interactive :test test) (cadr clause) ;bvl=3 forms))) ;body=4 clauses))) `(block ,block-tag (let ((,temp-var nil)) (tagbody (restart-bind ,(mapcar #'(lambda (datum) (let ((name (nth 0 datum)) (tag (nth 1 datum)) (keys (nth 2 datum))) `(,name #'(lambda (&rest temp) (setq ,temp-var temp) (go ,tag)) ,@keys))) data) (return-from ,block-tag ,(munge-restart-case-expression expression data env))) ,@(mapcan #'(lambda (datum) (let ((tag (nth 1 datum)) (bvl (nth 3 datum)) (body (nth 4 datum))) (list tag `(return-from ,block-tag (apply #'(lambda ,bvl ,@body) ,temp-var))))) data))))))) ;;; If just one body form, then don't use progn. This allows restart-case to ;;; "see" calls to error, etc. ;;; (defmacro with-simple-restart ((restart-name format-string &rest format-arguments) &body forms) "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) body) If restart-name is not invoked, then all values returned by forms are returned. If control is transferred to this restart, it immediately returns the values nil and t." `(restart-case ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) (,restart-name () :report (lambda (stream) (format stream ,format-string ,@format-arguments)) (values nil t)))) ;;;; Conditions. (eval-when (compile load eval) (defstruct (condition-class (:include slot-class)) ;; ;; List of CONDITION-SLOT structures for the direct slots of this class. (slots nil :type list) ;; ;; List of CONDITION-SLOT structures for all of the effective class slots of ;; this class. (class-slots nil :type list) ;; ;; Report function or NIL. (report nil :type (or function null)) ;; ;; List of alternating initargs and initforms. (default-initargs () :type list) ;; ;; CPL as a list of class objects, with all non-condition classes removed. (cpl () :type list) ;; ;; A list of all the effective instance allocation slots of this class that ;; have a non-constant initform or default-initarg. Values for these slots ;; must be computed in the dynamic environment of MAKE-CONDITION. (hairy-slots nil :type list)) ); eval-when (compile load eval) (defstruct (condition (:constructor make-condition-object (actual-initargs)) (:alternate-metaclass instance condition-class make-condition-class)) (function-name nil) ;; ;; Actual initargs supplied to MAKE-CONDITION. (actual-initargs (required-argument) :type list) ;; ;; Plist mapping slot names to any values that were assigned or defaulted ;; after creation. (assigned-slots () :type list)) (defstruct condition-slot (name (required-argument) :type symbol) ;; ;; List of all applicable initargs. (initargs (required-argument) :type list) ;; ;; Names of reader and writer functions. (readers (required-argument) :type list) (writers (required-argument) :type list) ;; ;; True if :INITFORM was specified. (initform-p (required-argument) :type (member t nil)) ;; ;; If a function, call it with no args. Otherwise, the actual value. (initform (required-argument) :type t) ;; ;; Allocation of this slot. Nil only until defaulted. (allocation nil :type (member :instance :class nil)) ;; ;; If :class allocation, a cons whose car holds the value. (cell nil :type (or cons null)) ;; ;; Slot documentation. (documentation nil :type (or null string))) (eval-when (compile load eval) (setf (condition-class-cpl (kernel::find-class 'condition)) (list (kernel::find-class 'condition)))) (setf (condition-class-report (kernel::find-class 'condition)) #'(lambda (cond stream) (format stream (intl:gettext "Condition ~S was signalled.") (type-of cond)))) (eval-when (compile load eval) (defun find-condition-layout (name parent-types) (let* ((cpl (remove-duplicates (reverse (reduce #'append (mapcar #'(lambda (x) (condition-class-cpl (kernel::find-class x))) parent-types))))) (cond-layout (info type compiler-layout 'condition)) (olayout (info type compiler-layout name)) (new-inherits (order-layout-inherits (concatenate 'simple-vector (layout-inherits cond-layout) (mapcar #'%class-layout cpl))))) (if (and olayout (not (mismatch (layout-inherits olayout) new-inherits))) olayout (make-layout :class (make-undefined-class name) :inherits new-inherits :inheritance-depth -1 :length (layout-length cond-layout))))) ); EVAL-WHEN (COMPILE LOAD EVAL) ;;;; Condition reporting: (defun %print-condition (s stream d) (declare (ignore d)) (if (fboundp 'print-object) (print-object s stream) (real-print-condition s stream))) (defun real-print-condition (s stream) (if *print-escape* (print-unreadable-object (s stream :identity t :type t)) (dolist (class (condition-class-cpl (kernel::class-of s)) (error (intl:gettext "No REPORT? Shouldn't happen!"))) (let ((report (condition-class-report class))) (when report (return (funcall report s stream))))))) ;;;; Condition slots: (defvar *empty-slot* '(empty)) (defun find-slot-default (class slot) (let ((initargs (condition-slot-initargs slot)) (cpl (condition-class-cpl class))) (dolist (class cpl) (let ((default-initargs (condition-class-default-initargs class))) (dolist (initarg initargs) (let ((val (getf default-initargs initarg *empty-slot*))) (unless (eq val *empty-slot*) (return-from find-slot-default (if (functionp val) (funcall val) val))))))) (if (condition-slot-initform-p slot) (let ((initform (condition-slot-initform slot))) (if (functionp initform) (funcall initform) initform)) (error (intl:gettext "Condition slot is not bound: ~S") (condition-slot-name slot))))) (defun find-slot (classes name) (dolist (sclass classes nil) (dolist (slot (condition-class-slots sclass)) (when (eq (condition-slot-name slot) name) (return-from find-slot slot))))) (defun condition-writer-function (condition new-value name) (dolist (cslot (condition-class-class-slots (layout-class (%instance-layout condition))) (setf (getf (condition-assigned-slots condition) name) new-value)) (when (eq (condition-slot-name cslot) name) (return (setf (car (condition-slot-cell cslot)) new-value))))) (defun condition-reader-function (condition name) (let ((class (layout-class (%instance-layout condition)))) (dolist (cslot (condition-class-class-slots class)) (when (eq (condition-slot-name cslot) name) (return-from condition-reader-function (car (condition-slot-cell cslot))))) (let ((val (getf (condition-assigned-slots condition) name *empty-slot*))) (if (eq val *empty-slot*) (let ((actual-initargs (condition-actual-initargs condition)) (slot (find-slot (condition-class-cpl class) name))) (unless slot (error (intl:gettext "Slot ~S of ~S missing.") name condition)) ;; ;; Loop over actual initargs because the order of ;; actual initargs determines how slots are initialized. (loop with slot-initargs = (condition-slot-initargs slot) for (initarg init-value) on actual-initargs by #'cddr if (member initarg slot-initargs) do (return-from condition-reader-function (setf (getf (condition-assigned-slots condition) name) init-value))) (setf (getf (condition-assigned-slots condition) name) (find-slot-default class slot))) val)))) (defun make-condition (thing &rest args) "Make an instance of a condition object using the specified initargs." ;; Note: ANSI specifies no exceptional situations in this function. ;; signalling simple-type-error would not be wrong. (let* ((thing (if (symbolp thing) (kernel::find-class thing) thing)) (class (typecase thing (condition-class thing) (pcl::condition-class ;; Punt to CLOS (return-from make-condition (apply #'make-instance thing args))) (class (error 'simple-type-error :datum thing :expected-type 'condition-class :format-control (intl:gettext "~S is not a condition class.") :format-arguments (list thing))) (t (error 'simple-type-error :datum thing :expected-type 'condition-class :format-control (intl:gettext "Bad thing for class arg:~% ~S") :format-arguments (list thing))))) (res (make-condition-object args))) (setf (%instance-layout res) (%class-layout class)) ;; ;; Set any class slots with initargs present in this call. (dolist (cslot (condition-class-class-slots class)) (dolist (initarg (condition-slot-initargs cslot)) (let ((val (getf args initarg *empty-slot*))) (unless (eq val *empty-slot*) (setf (car (condition-slot-cell cslot)) val))))) ;; ;; Default any slots with non-constant defaults now. (dolist (hslot (condition-class-hairy-slots class)) (when (dolist (initarg (condition-slot-initargs hslot) t) (unless (eq (getf args initarg *empty-slot*) *empty-slot*) (return nil))) (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) (find-slot-default class hslot)))) res)) ;;;; DEFINE-CONDITION (eval-when (compile load eval) (defun %compiler-define-condition (name direct-supers layout source-location) (multiple-value-bind (class old-layout) (insured-find-class name #'condition-class-p #'make-condition-class) (setf (layout-class layout) class) (setf (%class-direct-superclasses class) (mapcar #'kernel::find-class direct-supers)) (cond ((not old-layout) (register-layout layout)) ((not *type-system-initialized*) (setf (layout-class old-layout) class) (setq layout old-layout) (unless (eq (%class-layout class) layout) (register-layout layout))) ((redefine-layout-warning old-layout "current" layout "new") (register-layout layout :invalidate t)) ((not (%class-layout class)) (register-layout layout))) (setf (layout-info layout) (layout-info (%class-layout (kernel::find-class 'condition)))) (setf (kernel::find-class name) class) ;; ;; Initialize CPL slot. (setf (condition-class-cpl class) (remove-if-not #'condition-class-p (std-compute-class-precedence-list class))) (setf (info :source-location :class name) source-location)) (undefined-value)) ); eval-when (compile load eval) ;;; COMPUTE-EFFECTIVE-SLOTS -- Internal ;;; ;;; Compute the effective slots of class, copying inherited slots and ;;; side-effecting direct slots. ;;; (defun compute-effective-slots (class) (collect ((res (copy-list (condition-class-slots class)))) (dolist (sclass (cdr (condition-class-cpl class))) (dolist (sslot (condition-class-slots sclass)) (let ((found (find (condition-slot-name sslot) (res) :key #'condition-slot-name :test #'eq))) (cond (found (setf (condition-slot-initargs found) (union (condition-slot-initargs found) (condition-slot-initargs sslot))) (unless (condition-slot-initform-p found) (setf (condition-slot-initform-p found) (condition-slot-initform-p sslot)) (setf (condition-slot-initform found) (condition-slot-initform sslot))) (unless (condition-slot-allocation found) (setf (condition-slot-allocation found) (condition-slot-allocation sslot)))) (t (res (copy-structure sslot))))))) (res))) (eval-when (compile load eval) (defvar *make-condition-accessor-methods* nil)) ;;; ;;; List of condition slot readers and writers defined early. Used to ;;; change them to generic functions when PCL is ready to do so. ;;; Alas, we have to keep this list around after readers/writers have ;;; been made generic functions because the PCL build process requires ;;; us to undefine generic functions, so we need to change the ;;; accessors back to normal functions when building PCL. ;;; (defvar *early-condition-accessors* ()) (defun make-early-condition-accessors-generic (&optional (generic-p t)) (dolist (elt *early-condition-accessors*) (destructuring-bind (condition slot accessor kind) elt (fmakunbound accessor) (let ((new (make-condition-accessor accessor condition slot kind generic-p))) (when generic-p (eval new))))) (setq *make-condition-accessor-methods* generic-p)) (defun make-condition-accessor (accessor condition slot kind generic-p) (if generic-p (if (eq kind 'reader) `(defmethod ,accessor ((x ,condition)) (condition-reader-function x ',slot)) `(defmethod ,accessor (nv (x ,condition)) (condition-writer-function x nv ',slot))) (progn (pushnew (list condition slot accessor kind) *early-condition-accessors* :test #'equal) (setf (fdefinition accessor) (if (eq kind 'reader) (lambda (x) (condition-reader-function x slot)) (lambda (nv x) (condition-writer-function x nv slot))))))) (defun %define-condition (name slots documentation report default-initargs) (when (info declaration recognized name) (error (intl:gettext "Condition already names a declaration: ~S.") name)) (let ((class (kernel::find-class name))) (setf (slot-class-print-function class) #'%print-condition) (setf (condition-class-slots class) slots) (setf (condition-class-report class) report) (setf (condition-class-default-initargs class) default-initargs) (setf (documentation name 'type) documentation) (unless *make-condition-accessor-methods* (dolist (slot slots) (let ((slot-name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) (make-condition-accessor reader name slot-name 'reader nil)) (dolist (writer (condition-slot-writers slot)) (make-condition-accessor writer name slot-name 'writer nil))))) ;; ;; Compute effective slots and set up the class and hairy slots (subsets of ;; the effective slots.) (let ((eslots (compute-effective-slots class)) (e-def-initargs (reduce #'append (mapcar #'condition-class-default-initargs (condition-class-cpl class))))) (dolist (slot eslots) (ecase (condition-slot-allocation slot) (:class (unless (condition-slot-cell slot) (setf (condition-slot-cell slot) (list (if (condition-slot-initform-p slot) (let ((initform (condition-slot-initform slot))) (if (functionp initform) (funcall initform) initform)) *empty-slot*)))) (push slot (condition-class-class-slots class))) ((:instance nil) (setf (condition-slot-allocation slot) :instance) (when (or (functionp (condition-slot-initform slot)) (dolist (initarg (condition-slot-initargs slot) nil) (when (functionp (getf e-def-initargs initarg)) (return t)))) (push slot (condition-class-hairy-slots class)))))))) name) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* Define NAME as a condition type. This new type inherits slots and its report function from the specified PARENT-TYPEs. A slot spec is either a symbol denoting the name of the slot, or a list of the form: (slot-name {slot-option value}*) where slot-option is one of :READER, :WRITER, :ACCESSOR, :ALLOCATION, :INITARG, :INITFORM, :DOCUMENTATION, and :TYPE. Each overall option is of the form (option-name {value}*) where option-name is one of :DEFAULT-INITARGS, :DOCUMENTATION, and :REPORT. The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either a string or a two-argument lambda or function name. If a function, the function is called with the condition and stream to report the condition. If a string, the string is printed. Condition types are classes, but (as allowed by ANSI and not as described in CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and SLOT-VALUE may not be used on condition objects." (let* ((parent-types (or parent-types '(condition))) (layout (find-condition-layout name parent-types)) (documentation nil) (report nil) (slot-name/accessors ()) (default-initargs ())) (collect ((slots) (all-readers nil append) (all-writers nil append)) (dolist (spec slot-specs) (when (keywordp spec) (warn (intl:gettext "Keyword slot name indicates probable syntax error:~% ~S") spec)) (let* ((spec (if (consp spec) spec (list spec))) (slot-name (first spec)) (allocation :instance) (documentation nil) (initform-p nil) initform) (collect ((initargs) (readers) (writers)) (do ((options (rest spec) (cddr options))) ((null options)) (unless (and (consp options) (consp (cdr options))) (simple-program-error (intl:gettext "Malformed condition slot spec:~% ~S.") spec)) (let ((arg (second options))) (case (first options) (:reader (readers arg)) (:writer (writers arg)) (:accessor (readers arg) (writers `(setf ,arg))) (:initform (when initform-p (simple-program-error (intl:gettext "More than one :INITFORM in:~% ~S") spec)) (setq initform-p t) (setq initform arg)) (:initarg (initargs arg)) (:allocation (setq allocation arg)) (:documentation (when documentation (simple-program-error (intl:gettext "More than one slot :DOCUMENTATION in~% ~s") spec)) (unless (stringp arg) (simple-program-error (intl:gettext "Slot :DOCUMENTATION is not a string in~% ~s") spec)) (setq documentation arg)) (:type) (t (simple-program-error (intl:gettext "Unknown slot option:~% ~S") (first options)))))) (push (list slot-name (readers) (writers)) slot-name/accessors) (all-readers (readers)) (all-writers (writers)) (slots `(make-condition-slot :name ',slot-name :initargs ',(initargs) :readers ',(readers) :writers ',(writers) :initform-p ',initform-p :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) `#'(lambda () ,initform))))))) (dolist (option options) (unless (consp option) (simple-program-error (intl:gettext "Bad option:~% ~S") option)) (case (first option) (:documentation (setq documentation (second option))) (:report (let ((arg (second option))) (setq report (if (stringp arg) `#'(lambda (condition stream) (declare (ignore condition)) (write-string ,arg stream)) `#'(lambda (condition stream) (funcall #',arg condition stream)))))) (:default-initargs (do ((initargs (rest option) (cddr initargs))) ((endp initargs)) (let ((val (second initargs))) (setq default-initargs (list* `',(first initargs) (if (constantp val) `',(eval val) `#'(lambda () ,val)) default-initargs))))) (t (simple-program-error (intl:gettext "Unknown option: ~S") (first option))))) `(progn (eval-when (compile load eval) (%compiler-define-condition ',name ',parent-types ',layout (c::source-location))) (declaim (ftype (function (t) t) ,@(all-readers))) (declaim (ftype (function (t t) t) ,@(all-writers))) ,@(when *make-condition-accessor-methods* (collect ((methods)) (dolist (elt slot-name/accessors) (destructuring-bind (slot-name readers writers) elt (dolist (reader readers) (methods (make-condition-accessor reader name slot-name 'reader t))) (dolist (writer writers) (methods (make-condition-accessor writer name slot-name 'writer t))))) (methods))) (%define-condition ',name (list ,@(slots)) ,documentation ,report (list ,@default-initargs)))))) ;;;; HANDLER-BIND and SIGNAL. (defvar *handler-clusters* nil) (defmacro handler-bind (bindings &body forms) "(HANDLER-BIND ( {(type handler)}* ) body) Executes body in a dynamic context where the given handler bindings are in effect. Each handler must take the condition being signalled as an argument. The bindings are searched first to last in the event of a signalled condition." (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) (simple-program-error (intl:gettext "Ill-formed handler bindings."))) `(let ((*handler-clusters* (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) *handler-clusters*))) (multiple-value-prog1 (progn ,@forms) ;; Wait for any float exceptions #+x87 (float-wait)))) ;;;; Condition definitions. (define-condition serious-condition (condition)()) (define-condition error (serious-condition) ()) (define-condition warning (condition) ()) (define-condition style-warning (warning) ()) (defun simple-condition-printer (condition stream) (apply #'format stream (simple-condition-format-control condition) (simple-condition-format-arguments condition))) (define-condition simple-condition () ((format-control :reader simple-condition-format-control :initarg :format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments :initform '())) (:report simple-condition-printer)) (define-condition simple-warning (simple-condition warning) ()) (define-condition simple-style-warning (simple-condition style-warning) ()) (defun print-simple-error (condition stream) (format stream (intl:gettext "~&~@") (condition-function-name condition) (simple-condition-format-control condition) (simple-condition-format-arguments condition))) (define-condition simple-error (simple-condition error) () ;; This is the condition type used by error and cerror when ;; a format-control string is supplied as the first argument. (:report print-simple-error)) (define-condition storage-condition (serious-condition) ()) #+stack-checking (define-condition stack-overflow (storage-condition) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream _"Control stack overflow")))) #+heap-overflow-check (define-condition heap-overflow (storage-condition) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream _"Heap (dynamic space) overflow")))) (define-condition type-error (error) ((datum :reader type-error-datum :initarg :datum) (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report (lambda (condition stream) (format stream (intl:gettext "~@") (condition-function-name condition) (type-error-datum condition) (type-error-expected-type condition))))) (define-condition simple-type-error (simple-condition type-error) ()) (define-condition kernel:layout-invalid (type-error) () (:report (lambda (condition stream) (format stream (intl:gettext "Layout-invalid error in ~S:~@ Type test of class ~S was passed obsolete instance:~% ~S") (condition-function-name condition) (kernel:class-proper-name (type-error-expected-type condition)) (type-error-datum condition))))) (define-condition case-failure (type-error) ((name :reader case-failure-name :initarg :name) (possibilities :reader case-failure-possibilities :initarg :possibilities)) (:report (lambda (condition stream) (format stream (intl:gettext "~@<~S fell through ~S expression. ~:_Wanted one of ~:S.~:>") (type-error-datum condition) (case-failure-name condition) (case-failure-possibilities condition))))) (define-condition program-error (error) ()) (define-condition parse-error (error) ()) (define-condition control-error (error) ()) (define-condition stream-error (error) ((stream :reader stream-error-stream :initarg :stream))) (defun print-reference (reference stream) (ecase (car reference) (:amop (format stream "AMOP") (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type (:generic-function (format stream "Generic Function ~S" data)) (:section (format stream "Section ~{~D~^.~}" data))))) (:ansi-cl (format stream "The ANSI Standard") (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type (:function (format stream "Function ~S" data)) (:special-operator (format stream "Special Operator ~S" data)) (:macro (format stream "Macro ~S" data)) (:section (format stream "Section ~{~D~^.~}" data)) (:glossary (format stream "Glossary entry for ~S" data)) (:issue (format stream "writeup for Issue ~A" data))))) #+nil (:cmucl (format stream "The CMUCL Manual") (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type (:node (format stream "Node ~S" data)) (:variable (format stream "Variable ~S" data)) (:function (format stream "Function ~S" data))))) ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) )) (defun print-references (refs stream) (unless (or *print-escape* *print-readably*) (when refs (format stream "~&See also:~%") (pprint-logical-block (stream refs :per-line-prefix " ") (do* ((rs refs (cdr rs)) (r (car rs) (car rs))) ((null rs)) (print-reference r stream) (unless (null (cdr rs)) (terpri stream))))))) (define-condition reference-condition () ((references :initarg :references :reader reference-condition-references))) (define-condition end-of-file (stream-error) () (:report (lambda (condition stream) (format stream (intl:gettext "End-of-File on ~S") (stream-error-stream condition))))) (define-condition file-error (error) ((pathname :reader file-error-pathname :initarg :pathname))) ;;; INTERNAL (define-condition simple-program-error (simple-condition program-error)()) (define-condition simple-parse-error (simple-condition parse-error)()) (define-condition simple-control-error (simple-condition control-error)()) (define-condition simple-stream-error (simple-condition stream-error) ()) (define-condition simple-file-error (simple-condition file-error) () (:report (lambda (condition stream) (format stream (intl:gettext "~&~@") (condition-function-name condition) (simple-condition-format-control condition) (simple-condition-format-arguments condition))))) (define-condition package-error (error) ((package :reader package-error-package :initarg :package))) (define-condition cell-error (error) ((name :reader cell-error-name :initarg :name))) (define-condition unbound-variable (cell-error) () (:report (lambda (condition stream) (format stream (intl:gettext "Error in ~S: the variable ~S is unbound.") (condition-function-name condition) (cell-error-name condition))))) (define-condition undefined-function (cell-error) () (:report (lambda (condition stream) (format stream (intl:gettext "Error in ~S: the function ~S is undefined.") (condition-function-name condition) (cell-error-name condition))))) (define-condition simple-undefined-function (simple-condition undefined-function) ()) (define-condition constant-modified (reference-condition warning) ((function-name :initarg :function-name :reader constant-modified-function-name)) (:report (lambda (c s) (format s (intl:gettext "~@") (constant-modified-function-name c)) (print-references (reference-condition-references c) s))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) ;; For errors in CASE and friends. (define-condition invalid-case (reference-condition error) ((name :initarg :name :reader invalid-case-name) (format :initarg :format-control :reader invalid-case-format) (args :initarg :format-arguments :reader invalid-case-format-args)) (:report (lambda (condition stream) (format stream "~A: " (invalid-case-name condition)) (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) (print-references (reference-condition-references condition) stream)))) (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation :initform nil) (operands :reader arithmetic-error-operands :initarg :operands)) (:report (lambda (condition stream) (format stream (intl:gettext "Arithmetic error ~S signalled.") (type-of condition)) (when (arithmetic-error-operation condition) (format stream (intl:gettext "~%Operation was ~S, operands ~S.") (arithmetic-error-operation condition) (arithmetic-error-operands condition)))))) (define-condition division-by-zero (arithmetic-error) ()) (define-condition floating-point-overflow (arithmetic-error) ()) (define-condition floating-point-underflow (arithmetic-error) ()) (define-condition floating-point-inexact (arithmetic-error) ()) (define-condition floating-point-invalid-operation (arithmetic-error) ()) #+x86 (define-condition floating-point-denormal-operand (arithmetic-error) ()) ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that ;;; compiler warnings can be emitted as appropriate. ;;; (define-condition parse-unknown-type (condition) ((specifier :reader parse-unknown-type-specifier :initarg :specifier))) ;;;; HANDLER-CASE and IGNORE-ERRORS. ;;; This macro doesn't work in older version of CMUCL system due to lossage ;;; in closing over tags. The previous version sets up unique run-time tags. ;;; (defmacro handler-case (form &rest cases) "(HANDLER-CASE form { (type ([var]) body) }* ) Executes form in a context with handlers established for the condition types. A peculiar property allows type to be :no-error. If such a clause occurs, and form returns normally, all its values are passed to this clause as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one var specification." (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (make-symbol "normal-return")) (error-return (make-symbol "error-return"))) `(block ,error-return (multiple-value-call (lambda ,@(cdr no-error-clause)) (block ,normal-return (return-from ,error-return (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) (let ((tag (gensym)) (var (gensym)) (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) cases))) `(block ,tag (let ((,var nil)) (declare (ignorable ,var)) (tagbody (handler-bind ,(mapcar (lambda (annotated-case) (list (cadr annotated-case) `#'(lambda (temp) ,(if (caddr annotated-case) `(setq ,var temp) '(declare (ignore temp))) (go ,(car annotated-case))))) annotated-cases) (return-from ,tag #-x87 ,form #+x87 (multiple-value-prog1 ,form ;; Need to catch FP errors here! (kernel::float-wait)))) ,@(mapcan (lambda (annotated-case) (list (car annotated-case) (let ((body (cdddr annotated-case))) `(return-from ,tag ,(if (caddr annotated-case) `(let ((,(caaddr annotated-case) ,var)) ,@body) `(locally ,@body)))))) annotated-cases)))))))) (defmacro ignore-errors (&rest forms) "Executes forms after establishing a handler for all error conditions that returns from this form nil and the condition signalled." `(handler-case (progn ,@forms) (error (condition) (values nil condition)))) ;;;; Reader (define-condition standard-readtable-modified-error (reference-condition error) ((operation :initarg :operation :reader standard-readtable-modified-operation)) (:report (lambda (condition stream) (format stream "~S would modify the standard readtable." (standard-readtable-modified-operation condition)))) (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) (:ansi-cl :glossary "standard readtable")))) ;;;; Pprint dispatch (define-condition standard-pprint-dispatch-table-modified-error (reference-condition error) ((operation :initarg :operation :reader standard-pprint-dispatch-table-modified-operation)) (:report (lambda (condition stream) (format stream "~S would modify the standard pprint dispatch table." (standard-pprint-dispatch-table-modified-operation condition)))) (:default-initargs :references `((:ansi-cl :glossary "standard pprint dispatch table")))) ;;;; Restart definitions. (define-condition abort-failure (control-error) () (:report (lambda (condition stream) (declare (ignore condition)) (write-string (intl:gettext "Found an \"abort\" restart that failed to transfer control dynamically.") stream)))) ;;; ABORT signals an error in case there was a restart named abort that did ;;; not tranfer control dynamically. This could happen with RESTART-BIND. ;;; (defun abort (&optional condition) "Transfers control to a restart named abort, signalling a control-error if none exists." (invoke-restart (find-restart 'abort condition)) (error 'abort-failure)) (defun muffle-warning (&optional condition) "Transfers control to a restart named muffle-warning, signalling a control-error if none exists." (invoke-restart (find-restart 'muffle-warning condition))) ;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep ;;; INVOKE-RESTART from signalling a control-error condition. ;;; (defmacro define-nil-returning-restart (name args doc) `(defun ,name (,@args &optional condition) ,doc (let ((restart (find-restart ',name condition))) (when restart (invoke-restart restart ,@args))))) (define-nil-returning-restart continue () "Transfer control to a restart named continue, returning nil if none exists.") (define-nil-returning-restart store-value (value) "Transfer control and value to a restart named store-value, returning nil if none exists.") (define-nil-returning-restart use-value (value) "Transfer control and value to a restart named use-value, returning nil if none exists.") cmucl-21a/src/code/eval.lisp000066400000000000000000000443251260377556400161120ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/eval.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(eval constantp quote proclaim eval-when progn prog1 prog2 let let* do do* dotimes dolist progv and or cond if the macro-function special-operator-p *macroexpand-hook* macroexpand-1 macroexpand block return-from compiler-macro-function return function setq psetq apply funcall progv flet labels macrolet mapcar maplist mapc mapl mapcan mapcon tagbody prog prog* go values multiple-values-limit values-list multiple-value-list multiple-value-call multiple-value-prog1 multiple-value-bind multiple-value-setq catch unwind-protect throw defun lambda-list-keywords call-arguments-limit lambda-parameters-limit function-lambda-expression ;; ;; Declaration symbols referenced in the cold load. declare special ;; ;; Magical markers... lambda &optional &rest &key &aux &body &whole &allow-other-keys &environment)) #| Not implemented: *evalhook* *applyhook* evalhook applyhook |# (export '(eval::interpreted-function-p eval::interpreted-function-lambda-expression eval::interpreted-function eval::interpreted-function-arglist eval::interpreted-function-closure) "EVAL") (import '(eval::*eval-stack-top*)) (in-package "SYSTEM") (export '(parse-body find-if-in-closure)) (in-package "EXTENSIONS") (export '(*top-level-auto-declare* compiler-macroexpand-1 compiler-macroexpand)) (in-package "KERNEL") (export '(invoke-macroexpand-hook)) (in-package "LISP") (defconstant lambda-list-keywords '(&optional &rest &key &aux &body &whole &allow-other-keys &environment &parse-body c:&more) "Keywords that you can put in a lambda-list, supposing you should want to do such a thing.") (defconstant call-arguments-limit most-positive-fixnum "The exclusive upper bound on the number of arguments which may be passed to a function, including rest args.") (defconstant lambda-parameters-limit most-positive-fixnum "The exclusive upper bound on the number of parameters which may be specifed in a given lambda list. This is actually the limit on required and optional parameters. With &key and &aux you can get more.") (defconstant multiple-values-limit most-positive-fixnum "The exclusive upper bound on the number of multiple-values that you can have.") ;;;; (in-package "EVAL") ;;; This is defined here so that the printer &c can call ;;; interpreted-function-p before the full interpreter is loaded. ;;; Interpreted function. ;;; (defstruct (interpreted-function (:alternate-metaclass kernel:funcallable-instance kernel:funcallable-structure-class kernel:make-funcallable-structure-class) (:type kernel:funcallable-structure) (:constructor %make-interpreted-function) (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t) (lisp::output-interpreted-function s stream))))) ;; ;; The name of this interpreted function, or NIL if none specified. (%name nil) ;; ;; This function's debug arglist. (arglist nil) ;; ;; A lambda that can be converted to get the definition. (lambda nil) ;; ;; If this function has been converted, then this is the XEP. If this is ;; false, then the function is not in the cache (or is in the process of ;; being removed.) (definition nil :type (or c::clambda null)) ;; ;; The number of consecutive GCs that this function has been unused. This is ;; used to control cache replacement. (gcs 0 :type c::index) ;; ;; True if Lambda has been converted at least once, and thus warnings should ;; be suppressed on additional conversions. (converted-once nil) ;; ;; For a closure, the closure date vector. (closure nil :type (or null simple-vector))) ;;;; EVAL and friends. (in-package "LISP") ;;; ;;; This needs to be initialized in the cold load, since the top-level catcher ;;; will always restore the initial value. (defvar *eval-stack-top* 0) (declaim (type (member :warn t nil) *top-level-auto-declare*)) (defvar *top-level-auto-declare* :warn "This variable controls whether assignments to unknown variables at top-level (or in any other call to EVAL of SETQ) will implicitly declare the variable SPECIAL. These values are meaningful: :WARN -- Print a warning, but declare the variable special (the default.) T -- Quietly declare the variable special. NIL -- Never declare the variable, giving warnings on each use.") ;;; EVAL -- Public ;;; ;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. ;;; (defun eval (original-exp) "Evaluates its single arg in a null lexical environment, returns the result or results." (declare (optimize (safety 1))) (let ((exp (macroexpand original-exp))) (typecase exp (symbol (ecase (info variable kind exp) (:constant (values (info variable constant-value exp))) ((:special :global) (symbol-value exp)) ((:alien :macro) (eval:internal-eval original-exp)))) (list (let ((name (first exp)) (args (1- (length exp)))) (case name (function (unless (= args 1) (error 'simple-program-error :format-control (intl:gettext "Wrong number of args to FUNCTION:~% ~S.") :format-arguments (list exp))) (let ((name (second exp))) (cond ((consp name) (if (valid-function-name-p name) (fdefinition name) (eval:make-interpreted-function name))) ((macro-function name) (error 'simple-type-error :datum name :expected-type '(not (satisfies macro-function)) :format-control (intl:gettext "~S is a macro.") :format-arguments (list name))) ((special-operator-p name) (error 'simple-type-error :datum name :expected-type '(not (satisfies special-operator-p)) :format-control (intl:gettext "~S is a special operator.") :format-arguments (list name))) (t (fdefinition name))))) (quote (unless (= args 1) (error 'simple-program-error :format-control (intl:gettext "Wrong number of args to QUOTE:~% ~S.") :format-arguments (list exp))) (second exp)) (setq (unless (evenp args) (error 'simple-program-error :format-control (intl:gettext "Odd number of args to SETQ:~% ~S.") :format-arguments (list exp))) (unless (zerop args) (do ((name (cdr exp) (cddr name))) ((null name) (do ((args (cdr exp) (cddr args))) ((null (cddr args)) ;; We duplicate the call to SET so that the correct ;; value gets returned. (set (first args) (eval (second args)))) (set (first args) (eval (second args))))) (let ((symbol (first name))) (case (info variable kind symbol) (:special) (:global (case *top-level-auto-declare* (:warn (warn (intl:gettext "Declaring ~S special.") symbol)) ((t)) ((nil) (return (eval:internal-eval original-exp)))) (proclaim `(special ,symbol))) (t (return (eval:internal-eval original-exp)))))))) ((progn) (when (> args 0) (dolist (x (butlast (rest exp)) (eval (car (last exp)))) (eval x)))) ((eval-when) (when (plusp args) (let* ((situations (second exp)) (bad-situations (if (listp situations) (set-difference situations '(compile load eval :compile-toplevel :load-toplevel :execute)) situations))) (when (or (not (listp situations)) bad-situations) (warn (intl:gettext "Bad Eval-When situation list: ~S.") bad-situations)))) (if (and (> args 0) (or (member 'eval (second exp)) (member :execute (second exp)))) (when (> args 1) (dolist (x (butlast (cddr exp)) (eval (car (last exp)))) (eval x))) (eval:internal-eval original-exp))) (t (if (and (symbolp name) (eq (info function kind name) :function)) (collect ((args)) (dolist (arg (rest exp)) (args (eval arg))) (apply (symbol-function name) (args))) (eval:internal-eval original-exp)))))) (t exp)))) ;;; Dummy stubs for EVAL:INTERNAL-EVAL and EVAL:MAKE-INTERPRETED-FUNCTION in ;;; case the compiler isn't loaded yet. ;;; (declaim (notinline eval:internal-eval)) (defun eval:internal-eval (form &optional quietly env) (declare (ignore quietly env)) (error (intl:gettext "Attempt to evaluation a complex expression:~% ~S~@ This expression must be compiled, but the compiler is not loaded.") form)) ;;; (declaim (notinline eval:make-interpreted-function)) (defun eval:make-interpreted-function (x) (error (intl:gettext "EVAL called on #'(lambda (x) ...) when the compiler isn't loaded:~ ~% ~S~%") x)) ;;; FUNCTION-LAMBDA-EXPRESSION -- Public ;;; ;;; If interpreted, use the interpreter interface. Otherwise, see if it was ;;; compiled with COMPILE. If that fails, check for an inline expansion. ;;; (defun function-lambda-expression (fun) "Given a function, return three values: 1] A lambda expression that could be used to define the function, or NIL if the definition isn't available. 2] NIL if the function was definitely defined in a null lexical environment, and T otherwise. 3] Some object that \"names\" the function. Although this is allowed to be any object, CMU CL always returns a valid function name or a string." (declare (type function fun)) (if (eval:interpreted-function-p fun) (eval:interpreted-function-lambda-expression fun) (let* ((fun (%function-self fun)) (name (%function-name fun)) (code (di::function-code-header fun)) (info (kernel:%code-debug-info code))) (if info (let ((source (first (c::compiled-debug-info-source info)))) (cond ((and source (eq (c::debug-source-from source) :lisp) (eq (c::debug-source-info source) fun)) (values (second (svref (c::debug-source-name source) 0)) nil name)) ((stringp name) (values nil t name)) (t (let ((exp (info function inline-expansion name))) (if exp (values exp nil name) (values nil t name)))))) (values nil t name))))) ;;; FIND-IF-IN-CLOSURE -- Interface ;;; ;;; Like FIND-IF, only we do it on a compiled closure's environment. ;;; (defun find-if-in-closure (test fun) (dotimes (index (1- (get-closure-length fun))) (let ((elt (%closure-index-ref fun index))) (when (funcall test elt) (return elt))))) ;;;; Syntactic environment access: (defun special-operator-p (symbol) "If the symbol globally names a special form, returns T, otherwise NIL." (declare (symbol symbol)) (eq (info function kind symbol) :special-form)) (defvar *macroexpand-hook* 'funcall "The value of this variable must be a function that can take three arguments, a macro expander function, the macro form to be expanded, and the lexical environment to expand in. The function should return the expanded form. This function is called by MACROEXPAND-1 whenever a runtime expansion is needed. Initially this is set to FUNCALL.") ;;; INVOKE-MACROEXPAND-HOOK -- public. ;;; ;;; The X3J13 cleanup FUNCTION-TYPE:X3J13-MARCH-88 specifies that: ;;; ;;; "7. Clarify that the value of *MACROEXPAND-HOOK* is first coerced to a ;;; function before being called as the expansion interface hook by ;;; MACROEXPAND-1." ;;; ;;; This is a handy utility function that does just such a coercion. It also ;;; stores the result back in *macroexpand-hook* so we don't have to coerce ;;; it again. ;;; (defun invoke-macroexpand-hook (fun form env) "Invoke *MACROEXPAND-HOOK* on FUN, FORM, and ENV after coercing it to a function." (unless (functionp *macroexpand-hook*) (setf *macroexpand-hook* (coerce *macroexpand-hook* 'function))) (funcall *macroexpand-hook* fun form env)) (defun macro-function (symbol &optional env) "If SYMBOL names a macro in ENV, returns the expansion function, else returns NIL. If ENV is unspecified or NIL, use the global environment only." (declare (symbol symbol)) (let* ((fenv (when env (c::lexenv-functions env))) (local-def (cdr (assoc symbol fenv :key #'(lambda (e) (nth-value 1 (valid-function-name-p e))))))) (cond (local-def (if (and (consp local-def) (eq (car local-def) 'MACRO)) (cdr local-def) nil)) ((eq (info function kind symbol) :macro) (values (info function macro-function symbol))) (t nil)))) ;; This is supposed to take an optional env arg. But what should we ;; do with that? I (rtoy) don't know, so we do nothing right now. (defun (setf macro-function) (function symbol &optional env) (declare (symbol symbol) (type function function)) (when (eq (info function kind symbol) :special-form) (error (intl:gettext "~S names a special form.") symbol)) (setf (info function kind symbol) :macro) (setf (info function macro-function symbol) function) (setf (symbol-function symbol) #'(lambda (&rest args) (declare (ignore args)) (error 'simple-undefined-function :name symbol :format-control (intl:gettext "Cannot funcall macro functions.")))) function) ;;; Macroexpand-1 -- Public ;;; ;;; The Env is a LEXENV or NIL (the null environment.) ;;; (defun macroexpand-1 (form &optional env) "If form is a macro (or symbol macro), expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. Env is the lexical environment to expand in, which defaults to the null environment." (cond ((and (consp form) (symbolp (car form))) (let ((def (macro-function (car form) env))) (if def (values (invoke-macroexpand-hook def form env) t) (values form nil)))) ((symbolp form) (let* ((venv (when env (c::lexenv-variables env))) (local-def (cdr (assoc form venv)))) (cond (local-def (if (and (consp local-def) (eq (car local-def) 'macro)) (values (cdr local-def) t) (values form nil))) ((eq (info variable kind form) :macro) (values (info variable macro-expansion form) t)) (t (values form nil))))) (t (values form nil)))) (defun macroexpand (form &optional env) "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. Returns the final resultant form, and T if it was expanded. ENV is the lexical environment to expand in, or NIL (the default) for the null environment." (labels ((frob (form expanded) (multiple-value-bind (new-form newly-expanded) (macroexpand-1 form env) (if newly-expanded (frob new-form t) (values new-form expanded))))) (frob form nil))) (defun compiler-macro-function (name &optional env) "If NAME names a compiler-macro, returns the expansion function, else returns NIL. Note: if the name is shadowed in ENV by a local definition, or declared NOTINLINE, NIL is returned. Can be set with SETF." (let ((found (and env (cdr (assoc name (c::lexenv-functions env) :key #'(lambda (e) (nth-value 1 (valid-function-name-p e)))))))) (unless (eq (cond ((c::defined-function-p found) (c::defined-function-inlinep found)) (found :notinline) (t (info function inlinep name))) :notinline) (values (info function compiler-macro-function name))))) (defun (setf compiler-macro-function) (function name &optional env) (declare (type (or symbol list) name) (type (or function null) function)) (when (eq (info function kind name) :special-form) (error (intl:gettext "~S names a special form.") name)) (setf (info function compiler-macro-function name) function) function) ;;; While these have been dropped from the spec, and we don't use them ;;; internally, we implement them anyway, for the benefit of a user ;;; trying to debug his compiler macros. (defun compiler-macroexpand-1 (form &optional env) "If FORM is a function call for which a compiler-macro has been defined, invoke the expander function using *macroexpand-hook* and return the results and T. Otherwise, return the original form and NIL." (let ((fun (and (consp form) (compiler-macro-function (car form) env)))) (if fun (let ((result (invoke-macroexpand-hook fun form env))) (values result (not (eq result form)))) (values form nil)))) (defun compiler-macroexpand (form &optional env) "Repetitively call COMPILER-MACROEXPAND-1 until the form can no longer be expanded. ENV is the lexical environment to expand in, or NIL (the default) for the null environment." (labels ((frob (form expanded) (multiple-value-bind (new-form newly-expanded) (compiler-macroexpand-1 form env) (if newly-expanded (frob new-form t) (values new-form expanded))))) (frob form env))) (defun constantp (object &optional environment) "True of any Lisp object that has a constant value: types that eval to themselves, keywords, constants, and list whose car is QUOTE." (declare (ignore environment)) (typecase object (number t) (character t) (array t) (symbol (eq (info variable kind object) :constant)) (list (eq (car object) 'quote)) (function t) (instance t))) ;;; Function invocation: (defun apply (function arg &rest args) "Applies FUNCTION to a list of arguments produced by evaluating ARGS in the manner of LIST*. That is, a list is made of the values of all but the last argument, appended to the value of the last argument, which must be a list." (cond ((atom args) (apply function arg)) ((atom (cdr args)) (apply function (cons arg (car args)))) (t (do* ((a1 args a2) (a2 (cdr args) (cdr a2))) ((atom (cdr a2)) (rplacd a1 (car a2)) (apply function (cons arg args))))))) (defun funcall (function &rest arguments) "Calls Function with the given Arguments." (apply function arguments)) ;;; Multiple-Value forms: (defun values (&rest values) "Returns all of its arguments, in order, as values." (values-list values)) (defun values-list (list) "Returns all of the elements of List, in order, as values." (values-list list)) cmucl-21a/src/code/exports.lisp000066400000000000000000003530441260377556400166700ustar00rootroot00000000000000;;; -*- Log: C.Log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/exports.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; All the stuff necessary to export various symbols from various packages. ;;; (in-package "LISP") (intl:textdomain "cmucl") (if (find-package "PCL") (rename-package "PCL" "PCL" 'nil) (make-package "PCL" :nicknames 'nil :use nil)) (if (find-package "CLOS-MOP") (rename-package "CLOS-MOP" "CLOS-MOP" 'nil) (make-package "CLOS-MOP" :nicknames 'nil :use nil)) (if (find-package "C-CALL") (rename-package "C-CALL" "C-CALL" 'nil) (make-package "C-CALL" :nicknames 'nil :use nil)) (if (find-package "INSPECT") (rename-package "INSPECT" "INSPECT" 'nil) (make-package "INSPECT" :nicknames 'nil :use nil)) (if (find-package "BIGNUM") (rename-package "BIGNUM" "BIGNUM" 'nil) (make-package "BIGNUM" :nicknames 'nil :use nil)) (if (find-package "UNIX") (rename-package "UNIX" "UNIX" 'nil) (make-package "UNIX" :nicknames 'nil :use nil)) (if (find-package "FORMAT") (rename-package "FORMAT" "FORMAT" 'nil) (make-package "FORMAT" :nicknames 'nil :use nil)) (if (find-package "LISP") (rename-package "LISP" "LISP") (make-package "LISP" :nicknames 'nil :use nil)) (if (find-package "COMMON-LISP") (rename-package "COMMON-LISP" "COMMON-LISP" '("CL")) (make-package "COMMON-LISP" :nicknames '("CL") :use nil)) (if (find-package "EVAL") (rename-package "EVAL" "EVAL" 'nil) (make-package "EVAL" :nicknames 'nil :use nil)) #+pmax (if (find-package "PMAX") (rename-package "PMAX" "PMAX" '("VM")) (make-package "PMAX" :nicknames '("VM") :use nil)) #+sparc (if (find-package "SPARC") (rename-package "SPARC" "SPARC" '("VM")) (make-package "SPARC" :nicknames '("VM") :use nil)) #+ibmrt (if (find-package "RT") (rename-package "RT" "RT" '("VM")) (make-package "RT" :nicknames '("VM") :use nil)) #+x86 (if (find-package "X86") (rename-package "X86" "X86" '("VM")) (make-package "X86" :nicknames '("VM") :use nil)) #+amd64 (if (find-package "AMD64") (rename-package "AMD64" "AMD64" '("VM")) (make-package "AMD64" :nicknames '("VM") :use nil)) #+hppa (if (find-package "HPPA") (rename-package "HPPA" "HPPA" '("VM")) (make-package "HPPA" :nicknames '("VM") :use nil)) #+alpha (if (find-package "ALPHA") (rename-package "ALPHA" "ALPHA" '("VM")) (make-package "ALPHA" :nicknames '("VM") :use nil)) #+sgi (if (find-package "SGI") (rename-package "SGI" "SGI" '("VM")) (make-package "SGI" :nicknames '("VM") :use nil)) #+ppc (if (find-package "PPC") (rename-package "PPC" "PPC" '("VM")) (make-package "PPC" :nicknames '("VM"))) (if (find-package "CONDITIONS") (rename-package "CONDITIONS" "CONDITIONS" 'nil) (make-package "CONDITIONS" :nicknames 'nil :use nil)) (if (find-package "DISASSEM") (rename-package "DISASSEM" "DISASSEM" 'nil) (make-package "DISASSEM" :nicknames 'nil :use nil)) (if (find-package "DEBUG") (rename-package "DEBUG" "DEBUG" 'nil) (make-package "DEBUG" :nicknames 'nil :use nil)) (if (find-package "EXTENSIONS") (rename-package "EXTENSIONS" "EXTENSIONS" '("EXT")) (make-package "EXTENSIONS" :nicknames '("EXT") :use nil)) (if (find-package "DEBUG-INTERNALS") (rename-package "DEBUG-INTERNALS" "DEBUG-INTERNALS" '("DI")) (make-package "DEBUG-INTERNALS" :nicknames '("DI") :use nil)) (if (find-package "C") (rename-package "C" "C" '("OLD-C")) (make-package "C" :nicknames '("OLD-C") :use nil)) (if (find-package "XREF") (rename-package "XREF" "XREF" 'nil)) (if (find-package "WIRE") (rename-package "WIRE" "WIRE" 'nil) (make-package "WIRE" :nicknames 'nil :use nil)) (if (find-package "PRETTY-PRINT") (rename-package "PRETTY-PRINT" "PRETTY-PRINT" '("PP")) (make-package "PRETTY-PRINT" :nicknames '("PP") :use nil)) (if (find-package "SYSTEM") (rename-package "SYSTEM" "SYSTEM" '("SYS")) (make-package "SYSTEM" :nicknames '("SYS") :use nil)) (if (find-package "ALIEN") (rename-package "ALIEN" "ALIEN" 'nil) (make-package "ALIEN" :nicknames 'nil :use nil)) (if (find-package "ALIEN-INTERNALS") (rename-package "ALIEN-INTERNALS" "ALIEN-INTERNALS" 'nil) (make-package "ALIEN-INTERNALS" :nicknames 'nil :use nil)) (if (find-package "PROFILE") (rename-package "PROFILE" "PROFILE" 'nil) (make-package "PROFILE" :nicknames 'nil :use nil)) (if (find-package "COMMON-LISP-USER") (rename-package "COMMON-LISP-USER" "COMMON-LISP-USER" '("CL-USER")) (make-package "COMMON-LISP-USER" :nicknames '("CL-USER") :use nil)) (if (find-package "KERNEL") (rename-package "KERNEL" "KERNEL" 'nil) (make-package "KERNEL" :nicknames 'nil :use nil)) (if (find-package "NEW-ASSEM") (rename-package "NEW-ASSEM" "NEW-ASSEM" 'nil) (make-package "NEW-ASSEM" :nicknames 'nil :use nil)) (if (find-package "MULTIPROCESSING") (rename-package "MULTIPROCESSING" "MULTIPROCESSING" 'nil) (make-package "MULTIPROCESSING" :nicknames '("MP") :use nil)) (use-package '("SYSTEM" "ALIEN-INTERNALS" "ALIEN" "LISP") "C-CALL") (use-package '("KERNEL" "EXTENSIONS" "LISP") "INSPECT") (use-package '("LISP" "KERNEL") "BIGNUM") (use-package '("LISP") "UNIX") (use-package '("KERNEL" "LISP" "EXTENSIONS") "FORMAT") (use-package '("EXTENSIONS" "SYSTEM" "DEBUG" "KERNEL" "BIGNUM") "LISP") (use-package '("LISP" "KERNEL") "EVAL") (use-package '("C-CALL" "ALIEN-INTERNALS" "ALIEN" "BIGNUM" "LISP" "KERNEL" "EXTENSIONS" "SYSTEM" "C") "VM") (use-package '("EXTENSIONS" "LISP") "CONDITIONS") (use-package '("LISP") "DISASSEM") (use-package '("EXTENSIONS" "LISP" "SYSTEM") "DEBUG") (use-package '("C-CALL" "ALIEN" "COMMON-LISP" "SYSTEM") "EXTENSIONS") (use-package '("LISP" "SYSTEM" "EXTENSIONS" "KERNEL") "DEBUG-INTERNALS") (use-package '("ALIEN-INTERNALS" "ALIEN" "COMMON-LISP" "EXTENSIONS" "KERNEL" "SYSTEM" "BIGNUM") "C") (use-package '("LISP") "WIRE") (use-package '("KERNEL" "EXTENSIONS" "LISP") "PRETTY-PRINT") (use-package '("EXTENSIONS" "LISP") "SYSTEM") (use-package '("SYSTEM" "EXTENSIONS" "LISP") "ALIEN") (use-package '("LISP") "ALIEN-INTERNALS") (use-package '("COMMON-LISP") "PROFILE") (use-package '("EXTENSIONS" "COMMON-LISP") "COMMON-LISP-USER") (use-package '("ALIEN-INTERNALS" "LISP" "EXTENSIONS" "SYSTEM" "BIGNUM") "KERNEL") (use-package '("LISP") "NEW-ASSEM") (defpackage "ANSI-LOOP") (defpackage "C-CALL" (:import-from "COMMON-LISP" "CHAR" "FLOAT") (:export "C-STRING" "CHAR" "DOUBLE" "FLOAT" "INT" "LONG" "SHORT" "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT" "LONG-LONG" "UNSIGNED-LONG-LONG" "VOID")) (defpackage "INSPECT" (:export "*INTERFACE-STYLE*" "REMOVE-ALL-DISPLAYS" "REMOVE-OBJECT-DISPLAY" "SHOW-OBJECT")) (defpackage "BIGNUM" (:export "%ADD-WITH-CARRY" "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR" "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-SET" "%BIGNUM-SET-LENGTH" "%DIGIT-0-OR-PLUSP" "%DIGIT-LOGICAL-SHIFT-RIGHT" "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT" "%FLOOR" "%LOGAND" "%LOGIOR" "%LOGNOT" "%LOGXOR" "%MULTIPLY" "%MULTIPLY-AND-ADD" "%SUBTRACT-WITH-BORROW" "ADD-BIGNUMS" "BIGNUM-ASHIFT-LEFT" "BIGNUM-ASHIFT-RIGHT" "BIGNUM-COMPARE" "BIGNUM-DEPOSIT-BYTE" "BIGNUM-ELEMENT-TYPE" "BIGNUM-GCD" "BIGNUM-INDEX" "BIGNUM-INTEGER-LENGTH" "BIGNUM-LOAD-BYTE" "BIGNUM-LOGBITP" "BIGNUM-LOGCOUNT" "BIGNUM-LOGICAL-AND" "BIGNUM-LOGICAL-IOR" "BIGNUM-LOGICAL-NOT" "BIGNUM-LOGICAL-XOR" "BIGNUM-PLUS-P" "BIGNUM-TO-FLOAT" "BIGNUM-TRUNCATE" "BIGNUM-TYPE" "FLOAT-BIGNUM-RATIO" "MAKE-SMALL-BIGNUM" "MULTIPLY-BIGNUM-AND-FIXNUM" "MULTIPLY-BIGNUMS" "MULTIPLY-FIXNUMS" "NEGATE-BIGNUM" "SUBTRACT-BIGNUM")) (defpackage "UNIX" (:export "UNIX-CURRENT-DIRECTORY" "UNIX-OPEN" "UNIX-READ" "UNIX-WRITE" "UNIX-GETPAGESIZE" "UNIX-ERRNO" "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" "UNIX-RESOLVE-LINKS" "UNIX-SIMPLIFY-PATHNAME" "UNIX-CLOSE" "UNIX-STAT" "UNIX-LSTAT" "UNIX-FSTAT" "UNIX-GETHOSTNAME" "UNIX-LSEEK" "UNIX-EXIT" "UNIX-CHDIR" "UNIX-ACCESS" "UNIX-DUP" "UNIX-CHMOD" "UNIX-READLINK" "UNIX-RENAME" "UNIX-SELECT" "UNIX-FAST-GETRUSAGE" "UNIX-GETRUSAGE" "UNIX-GETTIMEOFDAY" "UNIX-ISATTY" "UNIX-MKDIR" "UNIX-RMDIR" "UNIX-UNLINK" "TIMEZONE" "TIMEVAL" "SIZE-T" "OFF-T" "INO-T" "DEV-T" "TIME-T" "USER-INFO-NAME" "INT64-T" "MODE-T" "UNIX-FAST-SELECT" "UNIX-PIPE" "UNIX-GETPID" "UNIX-GETHOSTID" "UNIX-UID" "UNIX-GID" "GET-UNIX-ERROR-MSG" "WINSIZE" "TIMEVAL" "CLOSE-DIR" "OPEN-DIR" "READ-DIR" ;; linux-os, sunos-os. "UNIX-UNAME" ;; filesys.lisp "UNIX-GETPWUID" ;; multi-proc.lisp "UNIX-SETITIMER" ;; run-program.lisp "UNIX-TTYNAME" "UNIX-IOCTL" "UNIX-OPENPTY" ;; alien-callback.lisp "UNIX-MPROTECT" ;; internet.lisp "UNIX-SOCKET" "UNIX-CONNECT" "UNIX-BIND" "UNIX-LISTEN" "UNIX-ACCEPT" "UNIX-GETSOCKOPT" "UNIX-SETSOCKOPT" "UNIX-GETPEERNAME" "UNIX-GETSOCKNAME" "UNIX-RECV" "UNIX-SEND" "UNIX-RECVFROM" "UNIX-SENDTO" "UNIX-SHUTDOWN" "UNIX-FCNTL" ;; serve-event.lisp "FD-SETSIZE" "FD-ISSET" "FD-CLR" ;; Simple streams "PROT_READ" "UNIX-MMAP" "UNIX-MUNMAP" "UNIX-MSYNC" ;; Motif "UNIX-GETUIO" ;; Hemlock "UNIX-CFGETOSPEED" "TERMIOS" "UNIX-TCGETATTR" "UNIX-TCSETATTR" "UNIX-FCHMOD" "UNIX-CREAT" "UNIX-UTIMES" ;; Tests "UNIX-SYMLINK" ;; Other symbols from structures, etc. "C-CC" "C-CFLAG" "C-IFLAG" "C-ISPEED" "C-LFLAG" "C-OFLAG" "C-OSPEED" "CHECK" "D-NAME" "D-RECLEN" "E2BIG" "EACCES" "EADDRINUSE" "EADDRNOTAVAIL" "EAFNOSUPPORT" "EAGAIN" "EALREADY" "EBADF" "EBUSY" "ECHILD" "ECONNABORTED" "ECONNREFUSED" "ECONNRESET" "EDEADLK" "EDESTADDRREQ" "EDOM" "EDQUOT" "EEXIST" "EFAULT" "EFBIG" "EHOSTDOWN" "EHOSTUNREACH" "EINPROGRESS" "EINTR" "EINVAL" "EIO" "EISCONN" "EISDIR" "ELOOP" "EMFILE" "EMLINK" "EMSGSIZE" "ENAMETOOLONG" "ENETDOWN" "ENETRESET" "ENETUNREACH" "ENFILE" "ENOBUFS" "ENODEV" "ENOENT" "ENOEXEC" "ENOMEM" "ENOPROTOOPT" "ENOSPC" "ENOTBLK" "ENOTCONN" "ENOTDIR" "ENOTEMPTY" "ENOTSOCK" "ENOTTY" "ENXIO" "EOPNOTSUPP" "EPERM" "EPFNOSUPPORT" "EPIPE" "EPROTONOSUPPORT" "EPROTOTYPE" "ERANGE" "EREMOTE" "EROFS" "ESHUTDOWN" "ESOCKTNOSUPPORT" "ESPIPE" "ESRCH" "ESUCCESS" "ETIMEDOUT" "ETOOMANYREFS" "ETXTBSY" "EUSERS" "EWOULDBLOCK" "EXDEV" "F-GETFL" "F-GETOWN" "F-SETFL" "F-SETOWN" "FAPPEND" "FASYNC" "FD-SET" "FD-ZERO" "FNDELAY" "F_OK" "GID-T" "IT-INTERVAL" "IT-VALUE" "ITIMERVAL" "L_INCR" "L_SET" "L_XTND" "MAP_ANONYMOUS" "MAP_FIXED" "MAP_PRIVATE" "MAP_SHARED" "MS_ASYNC" "MS_INVALIDATE" "MS_SYNC" "O_APPEND" "O_CREAT" "O_EXCL" "O_NDELAY" "O_NONBLOCK" "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "PROT_EXEC" "PROT_NONE" "PROT_WRITE" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS" "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND" "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK" "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" "R_OK" "S-IFBLK" "S-IFCHR" "S-IFDIR" "S-IFLNK" "S-IFMT" "S-IFREG" "S-IFSOCK" "SIGABRT" "SIGALRM" "SIGBUS" "SIGCHLD" "SIGCONT" "SIGCONTEXT" "SIGFPE" "SIGHUP" "SIGILL" "SIGINT" "SIGIO" "SIGIOT" "SIGKILL" "SIGMASK" "SIGPIPE" "SIGPROF" "SIGQUIT" "SIGSEGV" "SIGSTOP" "SIGTERM" "SIGTRAP" "SIGTSTP" "SIGTTIN" "SIGTTOU" "SIGURG" "SIGUSR1" "SIGUSR2" "SIGVTALRM" "SIGWINCH" "SIGXCPU" "SIGXFSZ" "ST-ATIME" "ST-BLKSIZE" "ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME" "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "TCSADRAIN" "TCSAFLUSH" "TCSANOW" "TIOCGPGRP" "TIOCGWINSZ" "TIOCNOTTY" "TIOCSPGRP" "TIOCSWINSZ" "TTY-BRKINT" "TTY-ECHO" "TTY-ECHOCTL" "TTY-ECHOE" "TTY-ECHOK" "TTY-ECHOKE" "TTY-ECHONL" "TTY-ECHOPRT" "TTY-FLUSHO" "TTY-ICANON" "TTY-ICRNL" "TTY-IEXTEN" "TTY-IGNBRK" "TTY-IGNCR" "TTY-IGNPAR" "TTY-IMAXBEL" "TTY-INLCR" "TTY-INPCK" "TTY-ISIG" "TTY-ISTRIP" "TTY-IXANY" "TTY-IXOFF" "TTY-IXON" "TTY-NOFLSH" "TTY-ONLCR" "TTY-OPOST" "TTY-PARMRK" "TTY-PENDIN" "TTY-TOSTOP" "TV-SEC" "TV-USEC" "TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-FD" "UNIX-FILE-KIND" "UNIX-FILE-MODE" "UNIX-GETUID" "UNIX-KILL" "UNIX-KILLPG" "UNIX-PATHNAME" "UNIX-SIGBLOCK" "UNIX-SIGNAL-DESCRIPTION" "UNIX-SIGNAL-NAME" "UNIX-SIGNAL-NUMBER" "UNIX-SIGPAUSE" "UNIX-SIGSETMASK" "USER-INFO" "USER-INFO-DIR" "USER-INFO-GECOS" "USER-INFO-GID" "USER-INFO-PASSWORD" "USER-INFO-SHELL" "USER-INFO-UID" "VDSUSP" "VEOF" "VEOL" "VEOL2" "VERASE" "VINTR" "VKILL" "VMIN" "VQUIT" "VSTART" "VSTOP" "VSUSP" "VTIME" "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL" "WS-YPIXEL" "W_OK" "X_OK" "FIONREAD" "TERMINAL-SPEEDS" ) (:export ;; For asdf "UNIX-GETENV" "UNIX-SETENV" "UNIX-PUTENV" "UNIX-UNSETENV" ;; For slime "UNIX-EXECVE" "UNIX-FORK") #-(or linux solaris) (:export "TCHARS" "LTCHARS" "D-NAMLEN" ;; run-program.lisp "SGTTYB" ;; Other symbols from structures, etc. "DIRECT" "ELOCAL" "EPROCLIM" "EVICEERR" "EVICEOP" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD" "F-GETFD" "F-SETFD" "FCREAT" "FEXCL" "FTRUNC" "READGRP" "READOTH" "READOWN" "S-IEXEC" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX" "S-IWRITE" "SAVETEXT" "SETGIDEXEC" "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL" "SG-OSPEED" "SIGEMT" "SIGSYS" "T-BRKC" "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC" "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCIFLUSH" "TCIOFLUSH" "TCOFLUSH" "TIOCFLUSH" "TIOCGETC" "TIOCGETP" "TIOCGLTC" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TTY-CBREAK" "TTY-CLOCAL" "TTY-CREAD" "TTY-CRMOD" "TTY-CS5" "TTY-CS6" "TTY-CS7" "TTY-CS8" "TTY-CSIZE" "TTY-CSTOPB" "TTY-HUPCL" "TTY-LCASE" "TTY-PARENB" "TTY-PARODD" "TTY-RAW" "TTY-TANDEM" "WRITEGRP" "WRITEOTH" ) #+linux (:export "TCHARS" "LTCHARS" "D-NAMLEN" ;; Other symbols "BLKCNT-T" "D-INO" "D-OFF" "EADV" "EBADE" "EBADFD" "EBADMSG" "EBADR" "EBADRQC" "EBADSLT" "EBFONT" "ECHRNG" "ECOMM" "EDEADLOCK" "EDOTDOT" "EIDRM" "EILSEQ" "EISNAM" "EL2HLT" "EL2NSYNC" "EL3HLT" "EL3RST" "ELIBACC" "ELIBBAD" "ELIBEXEC" "ELIBMAX" "ELIBSCN" "ELNRNG" "EMULTIHOP" "ENAVAIL" "ENOANO" "ENOCSI" "ENODATA" "ENOLCK" "ENOLINK" "ENOMSG" "ENONET" "ENOPKG" "ENOSR" "ENOSTR" "ENOSYS" "ENOTNAM" "ENOTUNIQ" "EOVERFLOW" "EPROTO" "EREMCHG" "EREMOTEIO" "ERESTART" "ESRMNT" "ESTALE" "ESTRPIPE" "ETIME" "EUCLEAN" "EUNATCH" "EXFULL" "O_NOCTTY" "SIGSTKFLT" "TTY-IUCLC" "TTY-OCRNL" "TTY-OFDEL" "TTY-OFILL" "TTY-OLCUC" "TTY-ONLRET" "TTY-ONOCR" "TTY-XCASE" "UNIX-DUP2" "UNIX-GETITIMER" "UNIX-PID" "UNIX-UNAME" "UTSNAME" ) #+solaris (:export "D-INO" "D-OFF" "DIRECT" "EADV" "EBADE" "EBADFD" "EBADMSG" "EBADR" "EBADRQC" "EBADSLT" "EBFONT" "ECANCELED" "ECHRNG" "ECOMM" "EDEADLOCK" "EIDRM" "EILSEQ" "EL2HLT" "EL2NSYNC" "EL3HLT" "EL3RST" "ELIBACC" "ELIBBAD" "ELIBEXEC" "ELIBMAX" "ELIBSCN" "ELNRNG" "EMULTIHOP" "ENOANO" "ENOCSI" "ENODATA" "ENOLCK" "ENOLINK" "ENOMSG" "ENONET" "ENOPKG" "ENOSR" "ENOSTR" "ENOSYS" "ENOTSUP" "ENOTUNIQ" "EOVERFLOW" "EPROTO" "EREMCHG" "ERESTART" "ESRMNT" "ESTALE" "ESTRPIPE" "ETIME" "EUNATCH" "EXECGRP" "EXECOTH" "EXECOWN" "EXFULL" "F-DUPFD" "F-GETFD" "F-SETFD" "FCREAT" "FEXCL" "FTRUNC" "LTCHARS" "O_NOCTTY" "RCV1EN" "READGRP" "READOTH" "READOWN" "S-IEXEC" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX" "S-IWRITE" "SAVETEXT" "SETGIDEXEC" "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL" "SG-OSPEED" "SGTTYB" "SIGEMT" "SIGSYS" "SIGWAITING" "T-BRKC" "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC" "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCHARS" "TCIFLUSH" "TCIOFLUSH" "TCOFLUSH" "TIOCFLUSH" "TIOCGETC" "TIOCGETP" "TIOCGLTC" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TTY-CBAUD" "TTY-CBREAK" "TTY-CLOCAL" "TTY-CREAD" "TTY-CRMOD" "TTY-CS5" "TTY-CS6" "TTY-CS7" "TTY-CS8" "TTY-CSIZE" "TTY-CSTOPB" "TTY-DEFECHO" "TTY-HUPCL" "TTY-IUCLC" "TTY-LCASE" "TTY-LOBLK" "TTY-OCRNL" "TTY-OFDEL" "TTY-OFILL" "TTY-OLCUC" "TTY-ONLRET" "TTY-ONOCR" "TTY-PARENB" "TTY-PARODD" "TTY-RAW" "TTY-TANDEM" "TTY-XCASE" "UNIX-TIMES" "UTSNAME" "WRITEGRP" "WRITEOTH" "XMT1EN" )) (defpackage "FORMAT") (defpackage "COMMON-LISP" (:nicknames "CL") ;; ;; It might be nicer if these symbols were from CL, but it's not ;; required, and moving them from EXT probably requires additional ;; magic, so I didn't do it. -- 2003-06-16, gerd. (:import-from "EXTENSIONS" "DEBUG" "FLOATING-POINT-INEXACT") (:export "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*" "**" "***" "*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUG-IO*" "*DEBUGGER-HOOK*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*FEATURES*" "*GENSYM-COUNTER*" "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-" "/" "//" "///" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABORT" "ABS" "ACONS" "ACOS" "ACOSH" "ADD-METHOD" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALLOCATE-INSTANCE" "ALPHA-CHAR-P" "ALPHANUMERICP" "AND" "APPEND" "APPLY" "APROPOS" "APROPOS-LIST" "AREF" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY" "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS" "ARRAY-DISPLACEMENT" "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-RANK-LIMIT" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAY-TOTAL-SIZE-LIMIT" "ARRAYP" "ASH" "ASIN" "ASINH" "ASSERT" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH" "ATOM" "BASE-CHAR" "BASE-STRING" "BIGNUM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2" "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR" "BIT-VECTOR-P" "BIT-XOR" "BLOCK" "BOOLE" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOOLEAN" "BOTH-CASE-P" "BOUNDP" "BREAK" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUILT-IN-CLASS" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CALL-ARGUMENTS-LIMIT" "CALL-METHOD" "CALL-NEXT-METHOD" "CAR" "CASE" "CATCH" "CCASE" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CEILING" "CELL-ERROR" "CELL-ERROR-NAME" "CERROR" "CHANGE-CLASS" "CHAR" "CHAR-CODE" "CHAR-CODE-LIMIT" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-GREATERP" "CHAR-INT" "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP" "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP" "CHECK-TYPE" "CIS" "CLASS" "CLASS-NAME" "CLASS-OF" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH" "CODE-CHAR" "COERCE" "COMPILATION-SPEED" "COMPILE" "COMPILE-FILE" "COMPILE-FILE-PATHNAME" "COMPILED-FUNCTION" "COMPILED-FUNCTION-P" "COMPILER-MACRO" "COMPILER-MACRO-FUNCTION" "COMPLEMENT" "COMPLEX" "COMPLEXP" "COMPUTE-APPLICABLE-METHODS" "COMPUTE-RESTARTS" "CONCATENATE" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS" "COND" "CONDITION" "CONJUGATE" "CONS" "CONSP" "CONSTANTLY" "CONSTANTP" "CONTINUE" "CONTROL-ERROR" "COPY-ALIST" "COPY-LIST" "COPY-PPRINT-DISPATCH" "COPY-READTABLE" "COPY-SEQ" "COPY-STRUCTURE" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF" "COUNT-IF-NOT" "CTYPECASE" "DEBUG" "DECF" "DECLAIM" "DECLARATION" "DECLARE" "DECODE-FLOAT" "DECODE-UNIVERSAL-TIME" "DEFCLASS" "DEFCONSTANT" "DEFGENERIC" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION" "DEFINE-METHOD-COMBINATION" "DEFINE-MODIFY-MACRO" "DEFINE-SETF-EXPANDER" "DEFINE-SYMBOL-MACRO" "DEFMACRO" "DEFMETHOD" "DEFPACKAGE" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DELETE-PACKAGE" "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DESCRIBE-OBJECT" "DESTRUCTURING-BIND" "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE" "DIVISION-BY-ZERO" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS" "DOCUMENTATION" "DOLIST" "DOTIMES" "DOUBLE-FLOAT" "DOUBLE-FLOAT-EPSILON" "DOUBLE-FLOAT-NEGATIVE-EPSILON" "DPB" "DRIBBLE" "DYNAMIC-EXTENT" "ECASE" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME" "END-OF-FILE" "ENDP" "ENOUGH-NAMESTRING" "ENSURE-DIRECTORIES-EXIST" "ENSURE-GENERIC-FUNCTION" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR" "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR" "FBOUNDP" "FCEILING" "FDEFINITION" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-STREAM" "FILE-STRING-LENGTH" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS" "FIND-CLASS" "FIND-IF" "FIND-IF-NOT" "FIND-METHOD" "FIND-PACKAGE" "FIND-RESTART" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM" "FLET" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FORMATTER" "FOURTH" "FRESH-LINE" "FROUND" "FTRUNCATE" "FTYPE" "FUNCALL" "FUNCTION" "FUNCTION-KEYWORDS" "FUNCTION-LAMBDA-EXPRESSION" "FUNCTIONP" "GCD" "GENERIC-FUNCTION" "GENSYM" "GENTEMP" "GET" "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME" "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES" "GET-SETF-EXPANSION" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GO" "GRAPHIC-CHAR-P" "HANDLER-BIND" "HANDLER-CASE" "HASH-TABLE" "HASH-TABLE-COUNT" "HASH-TABLE-P" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "HOST-NAMESTRING" "IDENTITY" "IF" "IGNORABLE" "IGNORE" "IGNORE-ERRORS" "IMAGPART" "IMPORT" "IN-PACKAGE" "INCF" "INITIALIZE-INSTANCE" "INLINE" "INPUT-STREAM-P" "INSPECT" "INTEGER" "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERACTIVE-STREAM-P" "INTERN" "INTERNAL-TIME-UNITS-PER-SECOND" "INTERSECTION" "INVALID-METHOD-ERROR" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "ISQRT" "KEYWORD" "KEYWORDP" "LABELS" "LAMBDA" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LAST" "LCM" "LDB" "LDB-TEST" "LDIFF" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT" "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT" "LEAST-POSITIVE-SINGLE-FLOAT" "LENGTH" "LET" "LET*" "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN" "LISTP" "LOAD" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-VALUE" "LOCALLY" "LOG" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGTEST" "LOGXOR" "LONG-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON" "LONG-SITE-NAME" "LOOP" "LOOP-FINISH" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE" "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MACROLET" "MAKE-ARRAY" "MAKE-BROADCAST-STREAM" "MAKE-CONCATENATED-STREAM" "MAKE-CONDITION" "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE" "MAKE-LIST" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "MAKE-METHOD" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE" "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL" "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAP-INTO" "MAPC" "MAPCAN" "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF" "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "METHOD" "METHOD-COMBINATION" "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "MIN" "MINUSP" "MISMATCH" "MOD" "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT" "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT" "MOST-POSITIVE-SINGLE-FLOAT" "MUFFLE-WARNING" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-PROG1" "MULTIPLE-VALUE-SETQ" "MULTIPLE-VALUES-LIMIT" "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NEXT-METHOD-P" "NIL" "NINTERSECTION" "NINTH" "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "NOT" "NOTANY" "NOTEVERY" "NOTINLINE" "NRECONC" "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE" "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTH-VALUE" "NTHCDR" "NULL" "NUMBER" "NUMBERP" "NUMERATOR" "NUNION" "ODDP" "OPEN" "OPEN-STREAM-P" "OPTIMIZE" "OR" "OTHERWISE" "OUTPUT-STREAM-P" "PACKAGE" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-NAME" "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST" "PACKAGEP" "PAIRLIS" "PARSE-ERROR" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-MATCH-P" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PI" "PLUSP" "POP" "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PPRINT-DISPATCH" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PRINT-NOT-READABLE" "PRINT-NOT-READABLE-OBJECT" "PRINT-OBJECT" "PRINT-UNREADABLE-OBJECT" "PROBE-FILE" "PROCLAIM" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "PROGRAM-ERROR" "PROGV" "PROVIDE" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "QUOTE" "RANDOM" "RANDOM-STATE" "RANDOM-STATE-P" "RASSOC" "RASSOC-IF" "RASSOC-IF-NOT" "RATIO" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ" "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING" "READ-LINE" "READ-PRESERVING-WHITESPACE" "READ-SEQUENCE" "READER-ERROR" "READTABLE" "READTABLE-CASE" "READTABLEP" "REAL" "REALP" "REALPART" "REDUCE" "REINITIALIZE-INSTANCE" "REM" "REMF" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT" "REMOVE-METHOD" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST" "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RETURN" "RETURN-FROM" "REVAPPEND" "REVERSE" "ROOM" "ROTATEF" "ROUND" "ROW-MAJOR-AREF" "RPLACA" "RPLACD" "SAFETY" "SATISFIES" "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SEQUENCE" "SERIOUS-CONDITION" "SET" "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER" "SET-PPRINT-DISPATCH" "SET-SYNTAX-FROM-CHAR" "SETF" "SETQ" "SEVENTH" "SHADOW" "SHADOWING-IMPORT" "SHARED-INITIALIZE" "SHIFTF" "SHORT-FLOAT" "SHORT-FLOAT-EPSILON" "SHORT-FLOAT-NEGATIVE-EPSILON" "SHORT-SITE-NAME" "SIGNAL" "SIGNED-BYTE" "SIGNUM" "SIMPLE-ARRAY" "SIMPLE-BASE-STRING" "SIMPLE-BIT-VECTOR" "SIMPLE-BIT-VECTOR-P" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-CONTROL" "SIMPLE-ERROR" "SIMPLE-STRING" "SIMPLE-STRING-P" "SIMPLE-TYPE-ERROR" "SIMPLE-VECTOR" "SIMPLE-VECTOR-P" "SIMPLE-WARNING" "SIN" "SINGLE-FLOAT" "SINGLE-FLOAT-EPSILON" "SINGLE-FLOAT-NEGATIVE-EPSILON" "SINH" "SIXTH" "SLEEP" "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-UNBOUND" "SLOT-VALUE" "SOFTWARE-TYPE" "SOFTWARE-VERSION" "SOME" "SORT" "SPACE" "SPECIAL" "SPECIAL-OPERATOR-P" "SPEED" "SQRT" "STABLE-SORT" "STANDARD" "STANDARD-CHAR" "STANDARD-CHAR-P" "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "STEP" "STORAGE-CONDITION" "STORE-VALUE" "STREAM" "STREAM-ELEMENT-TYPE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL" "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-STREAM" "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP" "STRUCTURE" "STRUCTURE-CLASS" "STRUCTURE-OBJECT" "STYLE-WARNING" "SUBLIS" "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL" "SYMBOL-FUNCTION" "SYMBOL-MACROLET" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP" "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "T" "TAGBODY" "TAILP" "TAN" "TANH" "TENTH" "TERPRI" "THE" "THIRD" "THROW" "TIME" "TRACE" "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TWO-WAY-STREAM" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE" "TYPE-ERROR" "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" "TYPE-OF" "TYPECASE" "TYPEP" "UNBOUND-SLOT" "UNBOUND-SLOT-INSTANCE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "UNEXPORT" "UNINTERN" "UNION" "UNLESS" "UNREAD-CHAR" "UNSIGNED-BYTE" "UNTRACE" "UNUSE-PACKAGE" "UNWIND-PROTECT" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P" "USE-PACKAGE" "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VARIABLE" "VECTOR" "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN" "WILD-PATHNAME-P" "WITH-ACCESSORS" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS" "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-SLOTS" "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-SEQUENCE" "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP")) (defpackage "INTL" (:use "COMMON-LISP") (:export "*LOCALE-DIRECTORIES*" "DGETTEXT" "DNGETTEXT" "GETTEXT" "INSTALL" "NGETTEXT" "READ-TRANSLATABLE-STRING" "SETLOCALE" "TEXTDOMAIN" "TRANSLATION-ENABLE" "TRANSLATION-DISABLE" "WITH-TEXTDOMAIN")) (defpackage "LISP" (:use "COMMON-LISP" "EXTENSIONS" "KERNEL" "SYSTEM" "DEBUG" "BIGNUM" "INTL") (:shadowing-import-from "COMMON-LISP" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "CLASS-OF" "FIND-CLASS") (:export "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "CLASS-OF" "FIND-CLASS" "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*" "**" "***" "*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUG-IO*" "*DEBUGGER-HOOK*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*FEATURES*" "*GENSYM-COUNTER*" "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-" "/" "//" "///" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABORT" "ABS" "ACONS" "ACOS" "ACOSH" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALPHA-CHAR-P" "ALPHANUMERICP" "AND" "APPEND" "APPLY" "APROPOS" "APROPOS-LIST" "AREF" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY" "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS" "ARRAY-DISPLACEMENT" "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-RANK-LIMIT" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAY-TOTAL-SIZE-LIMIT" "ARRAYP" "ASH" "ASIN" "ASINH" "ASSERT" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH" "ATOM" "BASE-CHAR" "BASE-STRING" "BIGNUM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2" "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR" "BIT-VECTOR-P" "BIT-XOR" "BLOCK" "BOOLE" "BOOLEAN" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOTH-CASE-P" "BOUNDP" "BREAK" "BREF" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUFFER-COPY" "BUFFER-SAP" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CALL-ARGUMENTS-LIMIT" "CAR" "CASE" "CATCH" "CCASE" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CEILING" "CELL-ERROR" "CERROR" "CHAR" "CHAR-CODE" "CHAR-CODE-LIMIT" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-GREATERP" "CHAR-INT" "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP" "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP" "CHECK-TYPE" "CIS" "CLASS-NAME" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH" "CODE-CHAR" "COERCE" "COMPILATION-SPEED" "COMPILE" "COMPILE-FILE" "COMPILE-FILE-PATHNAME" "COMPILED-FUNCTION" "COMPILED-FUNCTION-P" "COMPILER-MACRO" "COMPILER-MACRO-FUNCTION" "COMPLEMENT" "COMPLEX" "COMPLEXP" "COMPUTE-RESTARTS" "CONCATENATE" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS" "COND" "CONDITION" "CONJUGATE" "CONS" "CONSP" "CONSTANTLY" "CONSTANTP" "CONTINUE" "CONTROL-ERROR" "COPY-ALIST" "COPY-LIST" "COPY-PPRINT-DISPATCH" "COPY-READTABLE" "COPY-SEQ" "COPY-STRUCTURE" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF" "COUNT-IF-NOT" "CTYPECASE" "DEBUG" "DECF" "DECLAIM" "DECLARATION" "DECLARE" "DECODE-FLOAT" "DECODE-UNIVERSAL-TIME" "DEFCONSTANT" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION" "DEFINE-MODIFY-MACRO" "DEFINE-SYMBOL-MACRO" "DEFMACRO" "DEFPACKAGE" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DELETE-PACKAGE" "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DESTRUCTURING-BIND" "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE" "DIVISION-BY-ZERO" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS" "DOCUMENTATION" "DOLIST" "DOTIMES" "DOUBLE-FLOAT" "DOUBLE-FLOAT-EPSILON" "DOUBLE-FLOAT-NEGATIVE-EPSILON" "DPB" "DRIBBLE" "DYNAMIC-EXTENT" "ECASE" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME" "END-OF-FILE" "ENDIAN-SWAP-VALUE" "ENDP" "ENOUGH-NAMESTRING" "ENSURE-DIRECTORIES-EXIST" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR" "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR" "FBOUNDP" "FCEILING" "FDEFINITION" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-STREAM" "FILE-STRING-LENGTH" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS" "FIND-IF" "FIND-IF-NOT" "FIND-PACKAGE" "FIND-RESTART" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM" "FLET" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATING-POINT-DENORMAL-OPERAND" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FORMATTER" "FOURTH" "FRESH-LINE" "FROUND" "FTRUNCATE" "FTYPE" "FUNCALL" "FUNCTION" "FUNCTION-LAMBDA-EXPRESSION" "FUNCTIONP" "GCD" "GENERIC-FUNCTION" "GENSYM" "GENTEMP" "GET" "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME" "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GO" "GRAPHIC-CHAR-P" "HANDLER-BIND" "HANDLER-CASE" "HASH-TABLE" "HASH-TABLE-COUNT" "HASH-TABLE-P" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "HOST-NAMESTRING" "IDENTITY" "IF" "IGNORABLE" "IGNORE" "IGNORE-ERRORS" "IMAGPART" "IMPORT" "IN-PACKAGE" "INTERACTIVE-STREAM-P" "INCF" "INLINE" "INPUT-STREAM-P" "INSPECT" "INTEGER" "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERN" "INTERNAL-TIME-UNITS-PER-SECOND" "INTERSECTION" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "ISQRT" "KEYWORD" "KEYWORDP" "LABELS" "LAMBDA" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LAST" "LCM" "LDB" "LDB-TEST" "LDIFF" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT" "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT" "LEAST-POSITIVE-SINGLE-FLOAT" "LENGTH" "LET" "LET*" "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN" "LISTP" "LOAD" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-VALUE" "LOCALLY" "LOG" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGTEST" "LOGXOR" "LONG-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON" "LONG-SITE-NAME" "LOOP" "LOOP-FINISH" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE" "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MACROLET" "MAKE-ARRAY" "MAKE-BROADCAST-STREAM" "MAKE-CONCATENATED-STREAM" "MAKE-CONDITION" "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-LIST" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE" "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL" "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAP-INTO" "MAPC" "MAPCAN" "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF" "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "MIN" "MINUSP" "MISMATCH" "MOD" "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT" "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT" "MOST-POSITIVE-SINGLE-FLOAT" "MUFFLE-WARNING" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-PROG1" "MULTIPLE-VALUE-SETQ" "MULTIPLE-VALUES-LIMIT" "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NIL" "NINTERSECTION" "NINTH" "NOT" "NOTANY" "NOTEVERY" "NOTINLINE" "NRECONC" "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE" "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTH-VALUE" "NTHCDR" "NULL" "NUMBER" "NUMBERP" "NUMERATOR" "NUNION" "ODDP" "OPEN" "OPEN-STREAM-P" "OPTIMIZE" "OR" "OTHERWISE" "OUTPUT-STREAM-P" "PACKAGE" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-NAME" "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST" "PACKAGEP" "PAIRLIS" "PARSE-ERROR" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-MATCH-P" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PI" "PLUSP" "POP" "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PPRINT-DISPATCH" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PRINT-UNREADABLE-OBJECT" "PROBE-FILE" "PROCLAIM" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "PROGRAM-ERROR" "PROGV" "PROVIDE" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "QUOTE" "RANDOM" "RANDOM-STATE" "RANDOM-STATE-P" "RASSOC" "RASSOC-IF" "RASSOC-IF-NOT" "RATIO" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ" "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING" "READ-LINE" "READ-PRESERVING-WHITESPACE" "READ-SEQUENCE" "READER-ERROR" "READTABLE" "READTABLE-CASE" "READTABLEP" "REAL" "REALP" "REALPART" "REDUCE" "REM" "REMF" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST" "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RETURN" "RETURN-FROM" "REVAPPEND" "REVERSE" "ROOM" "ROTATEF" "ROUND" "ROW-MAJOR-AREF" "RPLACA" "RPLACD" "SAFETY" "SATISFIES" "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SEQUENCE" "SERIOUS-CONDITION" "SET" "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER" "SET-PPRINT-DISPATCH" "SET-SYNTAX-FROM-CHAR" "SETF" "SETQ" "SEVENTH" "SHADOW" "SHADOWING-IMPORT" "SHIFTF" "SHORT-FLOAT" "SHORT-FLOAT-EPSILON" "SHORT-FLOAT-NEGATIVE-EPSILON" "SHORT-SITE-NAME" "SIGNAL" "SIGNED-BYTE" "SIGNUM" "SIMPLE-ARRAY" "SIMPLE-BASE-STRING" "SIMPLE-BIT-VECTOR" "SIMPLE-BIT-VECTOR-P" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-CONTROL" "SIMPLE-ERROR" "SIMPLE-STRING" "SIMPLE-STRING-P" "SIMPLE-TYPE-ERROR" "SIMPLE-VECTOR" "SIMPLE-VECTOR-P" "SIMPLE-WARNING" "SIN" "SINGLE-FLOAT" "SINGLE-FLOAT-EPSILON" "SINGLE-FLOAT-NEGATIVE-EPSILON" "SINH" "SIXTH" "SLEEP" "SOFTWARE-TYPE" "SOFTWARE-VERSION" "SOME" "SORT" "SPACE" "SPECIAL" "SPECIAL-OPERATOR-P" "SPEED" "SQRT" "STABLE-SORT" "STANDARD-CHAR" "STANDARD-CHAR-P" "STEP" "STORAGE-CONDITION" "STORE-VALUE" "STREAM" "STREAM-ELEMENT-TYPE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL" "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-STREAM" "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP" "STRUCTURE" "STRUCTURE-OBJECT" "SUBLIS" "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL" "SYMBOL-FUNCTION" "SYMBOL-MACROLET" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP" "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "T" "TAGBODY" "TAILP" "TAN" "TANH" "TENTH" "TERPRI" "THE" "THIRD" "THROW" "TIME" "TRACE" "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TWO-WAY-STREAM" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE" "TYPE-ERROR" "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" "TYPE-OF" "TYPECASE" "TYPEP" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "UNEXPORT" "UNINTERN" "UNION" "UNLESS" "UNREAD-CHAR" "UNSIGNED-BYTE" "UNTRACE" "UNUSE-PACKAGE" "UNWIND-PROTECT" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P" "USE-PACKAGE" "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VARIABLE" "VECTOR" "VECTOR-ELT-WIDTH" "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN" "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS" "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING" "WRITE-SEQUENCE" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP" "ADD-METHOD" "ALLOCATE-INSTANCE" "CALL-METHOD" "CALL-NEXT-METHOD" "CHANGE-CLASS" "COMPUTE-APPLICABLE-METHODS" "DEFCLASS" "DEFGENERIC" "DEFINE-METHOD-COMBINATION" "DEFMETHOD" "DESCRIBE-OBJECT" "ENSURE-GENERIC-FUNCTION" "FIND-METHOD" "FUNCTION-KEYWORDS" "INITIALIZE-INSTANCE" "INVALID-METHOD-ERROR" "MAKE-INSTANCE" "MAKE-INSTANCES-OBSOLETE" "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "NEXT-METHOD-P" "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "PRINT-OBJECT" "REINITIALIZE-INSTANCE" "REMOVE-METHOD" "SHARED-INITIALIZE" "SLOT-BOUNDP" "SLOT-EXISTS-P" "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS" "WITH-SLOTS" "MAKE-METHOD" "UNBOUND-SLOT" "UNBOUND-SLOT-INSTANCE" "CELL-ERROR-NAME" "GET-SETF-EXPANSION" "STYLE-WARNING" "PRINT-NOT-READABLE-OBJECT" "DEFINE-SETF-EXPANDER" "PRINT-NOT-READABLE" "METHOD" "METHOD-COMBINATION" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "CHAR-TITLECASE" "TITLE-CASE-P" "GLYPH" "SGLYPH" "STRING-TO-NFC" "CODEPOINT-LIMIT" "CODEPOINT") ;; Unicode (:export "STRING-TO-NFC" "STRING-TO-NFD" "STRING-TO-NFKC" "STRING-TO-NFKD" "UNICODE-COMPLETE" "UNICODE-COMPLETE-NAME" "UNICODE-FULL-CASE-LOWER" "UNICODE-FULL-CASE-UPPER" "UNICODE-FULL-CASE-TITLE" "UNICODE-CATEGORY" "+UNICODE-CATEGORY-LOWER+" "+UNICODE-CATEGORY-OTHER+" "+UNICODE-CATEGORY-GRAPHIC+" "+UNICODE-CATEGORY-UPPER+" "+UNICODE-CATEGORY-TITLE+" "LOAD-ALL-UNICODE-DATA" "SURROGATES" "WITH-STRING-CODEPOINT-ITERATOR" "WITH-STRING-GLYPH-ITERATOR")) (defpackage "EVAL" (:export "*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" "*INTERPRETED-FUNCTION-CACHE-MINIMUM-SIZE*" "*INTERPRETED-FUNCTION-CACHE-THRESHOLD*" "FLUSH-INTERPRETED-FUNCTION-CACHE" "INTERNAL-EVAL" "INTERPRETED-FUNCTION" "INTERPRETED-FUNCTION-ARGLIST" "INTERPRETED-FUNCTION-CLOSURE" "INTERPRETED-FUNCTION-LAMBDA-EXPRESSION" "INTERPRETED-FUNCTION-NAME" "INTERPRETED-FUNCTION-P" "INTERPRETED-FUNCTION-TYPE" "MAKE-INTERPRETED-FUNCTION" "TRACE-EVAL")) (dolist (name '("%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET" "%SET-FDEFINITION" "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE" "%SVSET" "%TYPEP" "*READ-ONLY-SPACE-FREE-POINTER*" "*STATIC-SPACE-FREE-POINTER*" "CURRENT-DYNAMIC-SPACE-START" "DYNAMIC-0-SPACE-START" "DYNAMIC-1-SPACE-START" "FIXNUM" "READ-ONLY-SPACE-START" "SHORT-FLOAT-P" "STATIC-SPACE-START" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*")) (intern name "LISP")) (dolist (name '("%PRIMITIVE" "%STANDARD-CHAR-P")) (intern name "SYSTEM")) (intern "BIGNUM-TYPE" "BIGNUM") (dolist (name '("%SP-SET-DEFINITION" "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P" "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P" "DOUBLE-DOUBLE-FLOAT-P" "DOUBLE-DOUBLE-FLOAT")) (intern name "KERNEL")) (defpackage #+pmax "PMAX" #+sparc "SPARC" #+ibmrt "RT" #+x86 "X86" #+amd64 "AMD64" #+hppa "HPPA" #+alpha "ALPHA" #+sgi "SGI" #+ppc "PPC" (:nicknames "VM" #+(or pmax sgi) "MIPS") (:import-from "LISP" "%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET" "%SET-FDEFINITION" "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE" "%SVSET" "%TYPEP" "*READ-ONLY-SPACE-FREE-POINTER*" "*STATIC-SPACE-FREE-POINTER*" "CURRENT-DYNAMIC-SPACE-START" "DYNAMIC-0-SPACE-START" "DYNAMIC-1-SPACE-START" "FIXNUM" "READ-ONLY-SPACE-START" "SHORT-FLOAT-P" "STATIC-SPACE-START" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*") (:shadowing-import-from "KERNEL" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF") (:export "*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*" "AFTER-BREAKPOINT-TRAP" "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT" "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" "BASE-CHAR-REG-SC-NUMBER" "BASE-CHAR-STACK-SC-NUMBER" "BASE-CHAR-TYPE" "BIGNUM-DIGITS-OFFSET" "BIGNUM-TYPE" "BINDING-SIZE" "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP" "BYTE-CODE-CLOSURE-TYPE" "BYTE-CODE-FUNCTION-TYPE" "BYTE-BITS" "BYTE-REG-SC-NUMBER" "CATCH-BLOCK-CURRENT-CODE-SLOT" "CATCH-BLOCK-CURRENT-CONT-SLOT" "CATCH-BLOCK-CURRENT-UWP-SLOT" "CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT" "CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" "CATCH-BLOCK-SIZE-SLOT" "CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP" "CLOSURE-FUNCTION-HEADER-TYPE" "CLOSURE-FUNCTION-SLOT" "CLOSURE-HEADER-TYPE" "CLOSURE-INFO-OFFSET" "CODE-BREAKDOWN" "CODE-CODE-SIZE-SLOT" "CODE-CONSTANTS-OFFSET" "CODE-DEBUG-INFO-SLOT" "CODE-ENTRY-POINTS-SLOT" "CODE-HEADER-TYPE" "CODE-TRACE-TABLE-OFFSET-SLOT" "COMPLEX-ARRAY-TYPE" "COMPLEX-BIT-VECTOR-TYPE" "COMPLEX-DOUBLE-FLOAT-FILLER-SLOT" "COMPLEX-DOUBLE-FLOAT-IMAG-SLOT" "COMPLEX-DOUBLE-FLOAT-REAL-SLOT" "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-TYPE" "COMPLEX-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-STACK-SC-NUMBER" "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT" "COMPLEX-LONG-FLOAT-IMAG-SLOT" "COMPLEX-LONG-FLOAT-REAL-SLOT" "COMPLEX-LONG-FLOAT-SIZE" "COMPLEX-LONG-FLOAT-TYPE" "COMPLEX-LONG-REG-SC-NUMBER" "COMPLEX-LONG-STACK-SC-NUMBER" "COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT" "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-TYPE" "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER" "COMPLEX-SIZE" "COMPLEX-STRING-TYPE" "COMPLEX-TYPE" "COMPLEX-VECTOR-TYPE" "CONS-CAR-SLOT" "CONS-CDR-SLOT" "CONS-SIZE" "CONSTANT-SC-NUMBER" "CONTROL-STACK-FORK" "CONTROL-STACK-RESUME" "CONTROL-STACK-RETURN" "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS" "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT" "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE" "DOUBLE-FLOAT-EXPONENT-BYTE" "DOUBLE-FLOAT-BIAS" "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE" "DOUBLE-FLOAT-FILLER-SLOT" "DOUBLE-FLOAT-HIDDEN-BIT" "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX" "DOUBLE-FLOAT-NORMAL-EXPONENT-MIN" "DOUBLE-FLOAT-SIGNIFICAND-BYTE" "DOUBLE-FLOAT-SIZE" "DOUBLE-FLOAT-TRAPPING-NAN-BIT" "DOUBLE-FLOAT-TYPE" "DOUBLE-FLOAT-VALUE-SLOT" "DOUBLE-INT-CARG-REG-SC-NUMBER" "DOUBLE-REG-SC-NUMBER" "DOUBLE-STACK-SC-NUMBER" "DYLAN-FUNCTION-HEADER-TYPE" "ERROR-TRAP" "EVEN-FIXNUM-TYPE" "EXPORTED-STATIC-SYMBOLS" "EXTERN-ALIEN-NAME" "FDEFN-FUNCTION-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT" "FDEFN-SIZE" "FDEFN-TYPE" "FIND-HOLES" "FIXNUM" "FIXUP-CODE-OBJECT" "FLOAT-DENORMAL-TRAP-BIT" "FLOAT-DIVIDE-BY-ZERO-TRAP-BIT" "FLOAT-IMPRECISE-TRAP-BIT" "FLOAT-INVALID-TRAP-BIT" "FLOAT-OVERFLOW-TRAP-BIT" "FLOAT-SIGN-SHIFT" "FLOAT-UNDERFLOW-TRAP-BIT" "FLOATING-POINT-MODES" "FORWARDING-POINTER-TYPE" "FP-CONSTANT-SC-NUMBER" "FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER" "FUNCALLABLE-INSTANCE-FUNCTION-SLOT" "FUNCALLABLE-INSTANCE-HEADER-TYPE" "FUNCALLABLE-INSTANCE-INFO-OFFSET" "FUNCTION-ARGLIST-SLOT" "FUNCTION-CODE-OFFSET" "FUNCTION-END-BREAKPOINT-TRAP" "FUNCTION-HEADER-TYPE" "FUNCTION-NAME-SLOT" "FUNCTION-NEXT-SLOT" "FUNCTION-POINTER-TYPE" "FUNCTION-SELF-SLOT" "FUNCTION-TYPE-SLOT" "FUNCALLABLE-INSTANCE-LAYOUT-SLOT" "FUNCALLABLE-INSTANCE-LEXENV-SLOT" "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER" "IMMEDIATE-BASE-CHAR-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER" "IMMEDIATE-SC-NUMBER" "INSTANCE-HEADER-TYPE" "INSTANCE-POINTER-TYPE" "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGUMENTS" "INTERRUPTED-FLAG" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-TYPE" "LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE" "LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX" "LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE" "LONG-FLOAT-SIZE" "LONG-FLOAT-TRAPPING-NAN-BIT" "LONG-FLOAT-TYPE" "LONG-FLOAT-VALUE-SLOT" "LONG-REG-SC-NUMBER" "LONG-STACK-SC-NUMBER" "LOWTAG-BITS" "LOWTAG-LIMIT" "LOWTAG-MASK" "MEMORY-USAGE" "MOST-POSITIVE-COST" "NEGATIVE-IMMEDIATE-SC-NUMBER" "NON-DESCRIPTOR-REG-SC-NUMBER" "NULL-SC-NUMBER" "OBJECT-NOT-LIST-TRAP" "OBJECT-NOT-INSTANCE-TRAP" "ODD-FIXNUM-TYPE" "OFFSET-STATIC-SYMBOL" "OTHER-IMMEDIATE-0-TYPE" "OTHER-IMMEDIATE-1-TYPE" "OTHER-POINTER-TYPE" "PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP" "PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-HEADER" "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME" "PRIMITIVE-OBJECT-OPTIONS" "PRIMITIVE-OBJECT-P" "PRIMITIVE-OBJECT-SIZE" "PRIMITIVE-OBJECT-SLOTS" "PRIMITIVE-OBJECT-VARIABLE-LENGTH" "PRINT-ALLOCATED-OBJECTS" "RANDOM-IMMEDIATE-SC-NUMBER" "RATIO-DENOMINATOR-SLOT" "RATIO-NUMERATOR-SLOT" "RATIO-SIZE" "RATIO-TYPE" "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-TYPE" "RETURN-PC-RETURN-POINT-OFFSET" "SANCTIFY-FOR-EXECUTION" "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE" "SAP-STACK-SC-NUMBER" "SAP-TYPE" "SCAVENGER-HOOK-FUNCTION-SLOT" "SCAVENGER-HOOK-SIZE" "SCAVENGER-HOOK-TYPE" "SCAVENGER-HOOK-VALUE-SLOT" "SCAVENGER-HOOK-NEXT-SLOT" "SIGCONTEXT-FLOATING-POINT-MODES" "SIGCONTEXT-FLOAT-REGISTER" "SIGCONTEXT-PROGRAM-COUNTER" "SIGCONTEXT-REGISTER" "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER" "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE" "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE" "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE" "SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE" "SIMPLE-ARRAY-LONG-FLOAT-TYPE" "SIMPLE-ARRAY-SINGLE-FLOAT-TYPE" "SIMPLE-ARRAY-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE" "SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE" "SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE" "SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE" "SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE" "SIMPLE-BIT-VECTOR-TYPE" "SIMPLE-STRING-TYPE" "SIMPLE-VECTOR-TYPE" "SINGLE-FLOAT-BIAS" "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE" "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX" "SINGLE-FLOAT-NORMAL-EXPONENT-MIN" "SINGLE-FLOAT-SIGNIFICAND-BYTE" "SINGLE-FLOAT-SIZE" "SINGLE-FLOAT-TRAPPING-NAN-BIT" "SINGLE-FLOAT-TYPE" "SINGLE-FLOAT-VALUE-SLOT" "SINGLE-INT-CARG-REG-SC-NUMBER" "SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER" "SINGLE-STEP-BREAKPOINT-TRAP" "SINGLE-VALUE-RETURN-BYTE-OFFSET" "SLOT-DOCS" "SLOT-LENGTH" "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS" "SLOT-REST-P" "STATIC-FUNCTIONS" "STATIC-FUNCTION-OFFSET" "STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P" "STATIC-SYMBOLS" "STRUCTURE-USAGE" "SYMBOL-FUNCTION-SLOT" "SYMBOL-HASH-SLOT" "SYMBOL-HEADER-TYPE" "SYMBOL-NAME-SLOT" "SYMBOL-PACKAGE-SLOT" "SYMBOL-PLIST-SLOT" "SYMBOL-RAW-FUNCTION-ADDR-SLOT" "SYMBOL-SETF-FUNCTION-SLOT" "SYMBOL-SIZE" "SYMBOL-UNUSED-SLOT" "SYMBOL-VALUE-SLOT" "TARGET-BINDING-STACK-START" "TARGET-BYTE-ORDER" "TARGET-CONTROL-STACK-START" "TARGET-DYNAMIC-SPACE-START" "TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE" "TARGET-FOREIGN-LINKAGE-ENTRY-SIZE" "TARGET-FOREIGN-LINKAGE-SPACE-START" "TARGET-HEAP-ADDRESS-SPACE" "TARGET-MOST-NEGATIVE-FIXNUM" "TARGET-MOST-POSITIVE-FIXNUM" "TARGET-READ-ONLY-SPACE-START" "TARGET-STATIC-SPACE-START" "TRACE-TABLE-CALL-SITE" "TRACE-TABLE-FUNCTION-EPILOGUE" "TRACE-TABLE-FUNCTION-PROLOGUE" "TRACE-TABLE-NORMAL" "TYPE-BITS" "TYPE-MASK" "UNBOUND-MARKER-TYPE" "UNINTERNED-SYMBOL-COUNT" "UNSIGNED-IMMEDIATE-SC-NUMBER" "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" "UNWIND-BLOCK-CURRENT-CODE-SLOT" "UNWIND-BLOCK-CURRENT-CONT-SLOT" "UNWIND-BLOCK-CURRENT-UWP-SLOT" "UNWIND-BLOCK-ENTRY-PC-SLOT" "UNWIND-BLOCK-SIZE" "VALUE-CELL-HEADER-TYPE" "VALUE-CELL-SIZE" "VALUE-CELL-VALUE-SLOT" "VECTOR-DATA-OFFSET" "VECTOR-LENGTH-SLOT" "VECTOR-MUST-REHASH-SUBTYPE" "VECTOR-NORMAL-SUBTYPE" "VECTOR-VALID-HASHING-SUBTYPE" "WEAK-POINTER-BROKEN-SLOT" "WEAK-POINTER-NEXT-SLOT" "WEAK-POINTER-SIZE" "WEAK-POINTER-TYPE" "WEAK-POINTER-VALUE-SLOT" "WORD-BITS" "WORD-BYTES" "WORD-REG-SC-NUMBER" "WORD-SHIFT" "ZERO-SC-NUMBER" "CALLBACK-ACCESSOR-FORM" "MAKE-CALLBACK-TRAMPOLINE" "FIXNUMIZE" "WEAK-POINTER-MARK-BIT-SLOT" "CHAR-BITS" "CHAR-BYTES" ) #+x86 (:export "COMPATIBLE-FUNCTION-TYPES-P" "POSITIVE-FIXNUM-BITS" "FIXNUM-TAG-BITS" "FIXNUM-TAG-MASK") #+sparc (:export "ALLOCATION-TRAP" "POSITIVE-FIXNUM-BITS" "FIXNUM-TAG-BITS" "FIXNUM-TAG-MASK" "PSEUDO-ATOMIC-TRAP" "GET-FP-OPERANDS" "PSEUDO-ATOMIC-VALUE" "PSEUDO-ATOMIC-INTERRUPTED-VALUE" "COMPATIBLE-FUNCTION-TYPES-P" "SINGLE-FLOAT-BYTES" "DOUBLE-FLOAT-BYTES") #+ppc (:export "SIGCONTEXT-LR" "COMPATIBLE-FUNCTION-TYPES-P" "FLOAT-INVALID-OP-1-BYTE" "FLOAT-INVALID-OP-2-BYTE" "FLOAT-EXCEPTIONS-SUMMARY-BYTE" "GET-FP-OPERANDS" "FUSED-MULTIPLY-ADD" "FUSED-MULTIPLY-SUBTRACT") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-ERROR-TRAP" "DYNAMIC-SPACE-OVERFLOW-WARNING-TRAP") ;;#+double-double (:export "DOUBLE-DOUBLE-FLOAT" "DOUBLE-DOUBLE-FLOAT-TYPE" "DOUBLE-DOUBLE-FLOAT-HI-SLOT" "DOUBLE-DOUBLE-FLOAT-LO-SLOT" "DOUBLE-DOUBLE-FLOAT-FILLER-SLOT" "DOUBLE-DOUBLE-FLOAT-SIZE" "DOUBLE-DOUBLE-REG-SC-NUMBER" "DOUBLE-DOUBLE-STACK-SC-NUMBER" "DOUBLE-DOUBLE-FLOAT-DIGITS" "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE" "COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE" "COMPLEX-DOUBLE-DOUBLE-FLOAT-FILLER-SLOT" "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-HI-SLOT" "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-LO-SLOT" "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-HI-SLOT" "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-LO-SLOT" "COMPLEX-DOUBLE-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-DOUBLE-STACK-SC-NUMBER" "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE" )) (defpackage "CONDITIONS") (defpackage "DISASSEM" (:shadow "DISASSEMBLE") (:export "*NOTE-COLUMN*" "*OPCODE-COLUMN-WIDTH*" "ADD-COMMENT-HOOK" "ADD-HOOK" "ADD-NOTE-HOOK" "ARG-VALUE" "CREATE-DSTATE" "DISASSEM-STATE" "DISASSEMBLE" "DISASSEMBLE-CODE-COMPONENT" "DISASSEMBLE-FUNCTION" "DISASSEMBLE-MEMORY" "DISASSEMBLE-SEGMENT" "DISASSEMBLE-SEGMENTS" "DSTATE-CODE" "DSTATE-CURPOS" "DSTATE-GET-PROP" "DSTATE-NEXTPOS" "DSTATE-SEGMENT-LENGTH" "DSTATE-SEGMENT-SAP" "DSTATE-SEGMENT-START" "FIELD-TYPE" "FIND-INST" "GEN-FIELD-TYPE-DECL-FORM" "GEN-INST-DECL-FORM" "GEN-INST-FORMAT-DECL-FORM" "GET-CODE-SEGMENTS" "GET-FUNCTION-SEGMENTS" "GET-INST-SPACE" "HANDLE-BREAK-ARGS" "INST" "INST-FORMAT" "LABEL-SEGMENTS" "MAYBE-NOTE-ASSEMBLER-ROUTINE" "MAYBE-NOTE-STATIC-FUNCTION" "MAYBE-NOTE-ASSOCIATED-STORAGE-REF" "MAYBE-NOTE-NIL-INDEXED-OBJECT" "MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF" "MAYBE-NOTE-SINGLE-STORAGE-REF" "NOTE" "NOTE-CODE-CONSTANT" "PARAMS" "PRIN1-QUOTED-SHORT" "PRIN1-SHORT" "PRINT-BYTES" "PRINT-CURRENT-ADDRESS" "PRINT-FIELD" "PRINT-INST" "PRINT-INST-USING" "PRINT-NOTES-AND-NEWLINE" "PRINT-WORDS" "SAP-REF-DCHUNK" "SEG-DEBUG-FUNCTION" "SEG-LENGTH" "SEG-START" "SEGMENT" "SET-ADDRESS-PRINTING-RANGE" "SET-DISASSEM-PARAMS" "SET-DSTATE-SEGMENT" "SIGN-EXTEND" "SPECIALIZE" "GEN-PRINTER-DEF-FORMS-DEF-FORM" "MAKE-DSTATE" "DEFINE-ARGUMENT-TYPE" "GEN-ARG-TYPE-DEF-FORM" "READ-SIGNED-SUFFIX" "ADD-OFFS-HOOK" "MAKE-MEMORY-SEGMENT" "GEN-PREAMBLE-FORM" "MAKE-SEGMENT" "SEGMENT-OVERFLOW" "SEG-VIRTUAL-LOCATION" "MAKE-DECODED-INST" "DCHUNK" "*DEFAULT-DSTATE-HOOKS*" "MAKE-CODE-SEGMENT" "MAKE-OFFS-HOOK" "DSTATE-SEGMENT" "DSTATE-CUR-OFFS" "PRINC16" "INSTRUCTION" "DEFINE-INSTRUCTION-FORMAT" "DSTATE-NEXT-OFFS" "INSTALL-INST-FLAVORS" "SEG-SAP-MAKER" "DISASSEMBLE-ASSEM-SEGMENT" "GEN-CLEAR-INFO-FORM" "READ-SUFFIX" "MAP-SEGMENT-INSTRUCTIONS" "GEN-FORMAT-DEF-FORM" "SET-LOCATION-PRINTING-RANGE" "MAKE-VECTOR-SEGMENT" "ADD-OFFS-NOTE-HOOK" "ADD-OFFS-COMMENT-HOOK" "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR" #+sparc "MAYBE-NOTE-STATIC-FUNCTION" )) (dolist (name '("*MAX-TRACE-INDENTATION*" "*TRACED-FUNCTION-LIST*")) (intern name "EXTENSIONS")) (defpackage "DEBUG" (:import-from "EXTENSIONS" "*MAX-TRACE-INDENTATION*" "*TRACED-FUNCTION-LIST*") (:export "*AUTO-EVAL-IN-FRAME*" "*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*" "*DEBUG-PROMPT*" "*DEBUG-READTABLE*" "*FLUSH-DEBUG-ERRORS*" "*HELP-LINE-SCROLL-COUNT*" "*IN-THE-DEBUGGER*" "*MAX-TRACE-INDENTATION*" "*TRACE-FRAME*" "*TRACED-FUNCTION-LIST*" "ARG" "BACKTRACE" "INTERNAL-DEBUG" "VAR" "*PRINT-LOCATION-KIND*" "*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*" "*TRACE-VALUES*" "DO-DEBUG-COMMAND" "*TRACE-ENCAPSULATE-DEFAULT*" "*TRACE-ENCAPSULATE-PACKAGE-NAMES*" "*DEFAULT-PRINT-FRAME-CALL-VERBOSITY*")) (intern "CHAR" "LISP") ;; Make these STREAM symbols available (dolist (name '("STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "DESCRIBE-EXTERNAL-FORMAT")) (intern name "STREAM")) (defpackage "EXTENSIONS" (:nicknames "EXTENSIONS") (:import-from "LISP" "GET-SETF-METHOD") (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*") (:import-from "SYSTEM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P" "BINARY-TEXT-STREAM") #+double-double (:import-from "KERNEL" "DOUBLE-DOUBLE-FLOAT" "DD-PI") (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*" "DEBUG" "FLOATING-POINT-INEXACT" "*ANSI-DEFSTRUCT-OPTIONS-P*" "*AUTOLOAD-TRANSLATIONS*" "*BACKUP-EXTENSION*" "*BEFORE-GC-HOOKS*" "*BEFORE-SAVE-INITIALIZATIONS*" "*BLOCK-COMPILE-DEFAULT*" "*BYTES-CONSED-BETWEEN-GCS*" "*COMPATIBILITY-WARNINGS*" "*COMPILE-PROGRESS*" "*DERIVE-FUNCTION-TYPES*" "*DESCRIBE-IMPLEMENTATION-DETAILS*" "*DESCRIBE-INDENTATION*" "*DESCRIBE-LEVEL*" "*DESCRIBE-PRINT-LENGTH*" "*DESCRIBE-PRINT-LEVEL*" "*DESCRIBE-VERBOSE*" "*DISPLAY-EVENT-HANDLERS*" "*EDITOR-LISP-P*" "*EFFICIENCY-NOTE-COST-THRESHOLD*" "*EFFICIENCY-NOTE-LIMIT*" "*ENCLOSING-SOURCE-CUTOFF*" "*ENVIRONMENT-LIST*" "*ERROR-PRINT-LENGTH*" "*ERROR-PRINT-LEVEL*" "*GC-INHIBIT-HOOK*" "*GC-NOTIFY-AFTER*" "*GC-NOTIFY-BEFORE*" "*GC-VERBOSE*" "GET-SETF-METHOD" ; temp until uses are converted to g-s-expansion "*IGNORE-FLOATING-POINT-UNDERFLOW*" "*INFO-ENVIRONMENT*" "*INTEXP-MAXIMUM-EXPONENT*" "*KEYWORD-PACKAGE*" "*LISP-PACKAGE*" "*LOAD-IF-SOURCE-NEWER*" "*MAX-TRACE-INDENTATION*" "*MODULE-FILE-TRANSLATIONS*" "*PROMPT*" "*REQUIRE-VERBOSE*" "*MODULE-PROVIDER-FUNCTIONS*" "*SETF-FDEFINITION-HOOK*" "*TOP-LEVEL-AUTO-DECLARE*" "COMPILER-MACROEXPAND-1" "COMPILER-MACROEXPAND" "*UNDEFINED-WARNING-LIMIT*" "AMBIGUOUS-FILES" "ARGUMENT-LIST" "ASSQ" "BASIC-DEFINITION" "BIGNUMP" "BITP" "CALL-USER-MISCOP" "CANCEL-FINALIZATION" "CAREFUL-SYMBOL-FUNCTION" "CHAR" "CLEAN-UP-COMPILER" "CLEAR-INFO" "CLEAR-SEARCH-LIST" "COMPACT-INFO-ENVIRONMENT" "COMPILE-FROM-STREAM" "COMPILEDP" "COMPLETE-FILE" "CONSTANT" "CONSTANT-ARGUMENT" "CONSTANT-FUNCTION" "DEF-SOURCE-CONTEXT" "DEFAULT-DIRECTORY" "DEFINE-INFO-CLASS" "DEFINE-INFO-TYPE" "DEFMODULE" "DELQ" "DO-INFO" "ENCAPSULATE" "ENCAPSULATED-DEFINITION" "ENCAPSULATED-P" "END-BLOCK" "ENUMERATE-SEARCH-LIST" "FILE-WRITABLE" "FINALIZE" "FIXNUMP" "FORMAT-DECODED-TIME" "FORMAT-UNIVERSAL-TIME" "FREEZE-TYPE" "GC" "GC-OFF" "GC-ON" "GET-BYTES-CONSED" "GET-BYTES-CONSED-DFIXNUM" "GET-STREAM-COMMAND" "INFO" "INHIBIT-WARNINGS" "INTERACTIVE-EVAL" "LOAD-FOREIGN" "MAKE-CASE-FROB-STREAM" "MAKE-INFO-ENVIRONMENT" "MAKE-SCAVENGER-HOOK" "MAKE-STREAM-COMMAND" "MAKE-WEAK-POINTER" "MAYBE-INLINE" "MEMQ" "OPTIMIZE-INTERFACE" "PACKAGE-CHILDREN" "PACKAGE-PARENT" "PARSE-TIME" "PACKAGE-LOCK" "PACKAGE-DEFINITION-LOCK" "WITHOUT-PACKAGE-LOCKS" "UNLOCK-ALL-PACKAGES" "PRINT-DIRECTORY" "PRINT-HERALD" "PUTF" "PURGE-BACKUP-FILES" "QUIT" "RATIOP" "REALP" "RESET-FOREIGN-POINTERS" "SAVE" "SAVE-LISP" "SCAVENGER-HOOK" "SCAVENGER-HOOK-P" "SCAVENGER-HOOK-VALUE" "SCAVENGER-HOOK-FUNCTION" "SEARCH-LIST" "SET-SYMBOL-FUNCTION-CAREFULLY" "START-BLOCK" "STREAM-COMMAND" "STREAM-COMMAND-ARGS" "STREAM-COMMAND-NAME" "STREAM-COMMAND-P" "INSTANCEP" "SYMBOLICATE" "TRULY-THE" "UNCOMPILE" "UNENCAPSULATE" "UNIX-NAMESTRING" "WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE" "FEATUREP" "*IGNORE-EXTRA-CLOSE-PARENTHESES*" "*HERALD-ITEMS*" "SEARCH-LIST-DEFINED-P" "BYTES-CONSED-BETWEEN-GCS" "*LOAD-SOURCE-TYPES*" "*LOAD-OBJECT-TYPES*" "*DEFAULT-PACKAGE-USE-LIST*" "*GC-RUN-TIME*" "DEFINE-HASH-TABLE-TEST" "*EFFICIENCY-NOTE-LIMIT*" "*ERROR-PRINT-LINES*" "*INLINE-EXPANSION-LIMIT*" "INSTANCE" "*EFFICIENCY-NOTE-COST-THRESHOLD*" "*USE-IMPLEMENTATION-TYPES*" "*BYTE-COMPILE-TOP-LEVEL*" "*BYTE-COMPILE-DEFAULT*" "PURIFY" "MAP-APROPOS" "COMPILER-LET" "DEFINE-FUNCTION-NAME-SYNTAX" "VALID-FUNCTION-NAME-P" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P" "&PARSE-BODY" "*TRUST-DYNAMIC-EXTENT-DECLARATIONS*" "INVALID-FASL") ;; run-program (:export "RUN-PROGRAM" "PROCESS-ALIVE-P" "PROCESS-CLOSE" "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P" "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" "PROCESS-STATUS-HOOK" "PROCESS-WAIT") ;; Float extensions (:export "SINGLE-FLOAT-POSITIVE-INFINITY" "SHORT-FLOAT-POSITIVE-INFINITY" "DOUBLE-FLOAT-POSITIVE-INFINITY" "LONG-FLOAT-POSITIVE-INFINITY" "SINGLE-FLOAT-NEGATIVE-INFINITY" "SHORT-FLOAT-NEGATIVE-INFINITY" "DOUBLE-FLOAT-NEGATIVE-INFINITY" "LONG-FLOAT-NEGATIVE-INFINITY" "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES" "FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P" "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" "FLOAT-SIGNALING-NAN-P" "WITH-FLOAT-TRAPS-MASKED") ;; More float extensions #+double-double (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" "LEAST-POSITIVE-DOUBLE-DOUBLE-FLOAT" "LEAST-NEGATIVE-DOUBLE-DOUBLE-FLOAT" "MOST-POSITIVE-DOUBLE-DOUBLE-FLOAT" "MOST-NEGATIVE-DOUBLE-DOUBLE-FLOAT" "DOUBLE-DOUBLE-FLOAT-NEGATIVE-INFINITY" "DOUBLE-DOUBLE-FLOAT-POSITIVE-INFINITY") ;; Spice lisp extensions (:export "LETF*" "LETF" "DOVECTOR" "DELETEF" "INDENTING-FURTHER" "FILE-COMMENT" "READ-CHAR-NO-EDIT" "LISTEN-SKIP-WHITESPACE" "CONCAT-PNAMES" "ITERATE" "ONCE-ONLY" "COLLECT" "DO-ANONYMOUS" "UNDEFINED-VALUE" "REQUIRED-ARGUMENT" "DEFINE-HASH-CACHE" "DEFUN-CACHED" "CACHE-HASH-EQ" "DO-HASH") ;; Gray streams extension. (:export "FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM" "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" "FUNDAMENTAL-CHARACTER-INPUT-STREAM" "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-OUTPUT-STREAM" "FUNDAMENTAL-STREAM" "STREAM-ADVANCE-TO-COLUMN" "STREAM-CLEAR-INPUT" "STREAM-CLEAR-OUTPUT" "STREAM-FILE-POSITION" "STREAM-FINISH-OUTPUT" "STREAM-FORCE-OUTPUT" "STREAM-FRESH-LINE" "STREAM-LINE-COLUMN" "STREAM-LINE-LENGTH" "STREAM-LISTEN" "STREAM-PEEK-CHAR" "STREAM-READ-BYTE" "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE" "STREAM-START-LINE-P" "STREAM-TERPRI" "STREAM-UNREAD-CHAR" "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-STRING" "STREAM-READ-SEQUENCE" "STREAM-WRITE-SEQUENCE") ;; Commandline parsing (:export "*COMMAND-LINE-WORDS*" "*COMMAND-LINE-SWITCHES*" "*COMMAND-SWITCH-DEMONS*" "*COMMAND-LINE-UTILITY-NAME*" "*COMMAND-LINE-STRINGS*" "*BATCH-MODE*" "*COMMAND-LINE-APPLICATION-ARGUMENTS*" "CMD-SWITCH-STRING" "COMMAND-LINE-SWITCH-P" "CMD-SWITCH-NAME" "CMD-SWITCH-VALUE" "CMD-SWITCH-WORDS" "COMMAND-LINE-SWITCH" "DEFSWITCH" "CMD-SWITCH-ARG" "GET-COMMAND-LINE-SWITCH") ;; PCL declaration identifiers. (:export "SLOTS" "AUTO-COMPILE" "NOT-AUTO-COMPILE") ;; From internet.lisp (:export "HTONL" "NTOHL" "HTONS" "NTOHS" "LOOKUP-HOST-ENTRY" "HOST-ENTRY" "HOST-ENTRY-NAME" "HOST-ENTRY-ALIASES" "HOST-ENTRY-ADDR-LIST" "HOST-ENTRY-ADDR" "IP-STRING" "BIND-INET-SOCKET" "CREATE-UNIX-SOCKET" "CONNECT-TO-UNIX-SOCKET" "CREATE-UNIX-LISTENER" "ACCEPT-UNIX-CONNECTION" "CREATE-INET-SOCKET" "CONNECT-TO-INET-SOCKET" "CREATE-INET-LISTENER" "ACCEPT-TCP-CONNECTION" "CLOSE-SOCKET" "IPPROTO-TCP" "IPPROTO-UDP" "INADDR-ANY" "ADD-OOB-HANDLER" "REMOVE-OOB-HANDLER" "REMOVE-ALL-OOB-HANDLERS" "SEND-CHARACTER-OUT-OF-BAND" "SOCKET-ERROR" "INET-RECVFROM" "INET-SENDTO" "INET-SHUTDOWN" "SHUT-RD" "SHUT-WR" "SHUT-RDWR" "GET-PEER-HOST-AND-PORT" "GET-SOCKET-HOST-AND-PORT" "OPEN-NETWORK-STREAM" "ACCEPT-NETWORK-STREAM") ;; CLX extensions (:export "OPEN-CLX-DISPLAY" "WITH-CLX-EVENT-HANDLING" "ENABLE-CLX-EVENT-HANDLING" "DISABLE-CLX-EVENT-HANDLING" "OBJECT-SET-EVENT-HANDLER" "DEFAULT-CLX-EVENT-HANDLER" "FLUSH-DISPLAY-EVENTS" "CAREFULLY-ADD-FONT-PATHS" ;; Not sure if this should be exported or not. It's not ;; listed in clx-ext.lisp. "*CLX-FDS-TO-DISPLAYS*" "SERVE-KEY-PRESS" "SERVE-KEY-RELEASE" "SERVE-BUTTON-PRESS" "SERVE-BUTTON-RELEASE" "SERVE-MOTION-NOTIFY" "SERVE-ENTER-NOTIFY" "SERVE-LEAVE-NOTIFY" "SERVE-FOCUS-IN" "SERVE-FOCUS-OUT" "SERVE-EXPOSURE" "SERVE-GRAPHICS-EXPOSURE" "SERVE-NO-EXPOSURE" "SERVE-VISIBILITY-NOTIFY" "SERVE-CREATE-NOTIFY" "SERVE-DESTROY-NOTIFY" "SERVE-UNMAP-NOTIFY" "SERVE-MAP-NOTIFY" "SERVE-MAP-REQUEST" "SERVE-REPARENT-NOTIFY" "SERVE-CONFIGURE-NOTIFY" "SERVE-GRAVITY-NOTIFY" "SERVE-RESIZE-REQUEST" "SERVE-CONFIGURE-REQUEST" "SERVE-CIRCULATE-NOTIFY" "SERVE-CIRCULATE-REQUEST" "SERVE-PROPERTY-NOTIFY" "SERVE-SELECTION-CLEAR" "SERVE-SELECTION-REQUEST" "SERVE-SELECTION-NOTIFY" "SERVE-COLORMAP-NOTIFY" "SERVE-CLIENT-MESSAGE") ;; CLtL2 environment access. (:export "VARIABLE-INFORMATION" "FUNCTION-INFORMATION" "DECLARATION-INFORMATION" "PARSE-MACRO" "AUGMENT-ENVIRONMENT") ;; CMUCL extension for binary/text streams (:export "BINARY-TEXT-STREAM" "READ-VECTOR" "WRITE-VECTOR") ;; Hemlock (main.lisp, key-event.lisp, keytran.lisp) (:export "DEFINE-KEYSYM" "DEFINE-MOUSE-KEYSYM" "NAME-KEYSYM" "KEYSYM-NAMES" "KEYSYM-PREFERRED-NAME" "DEFINE-KEY-EVENT-MODIFIER" "DEFINE-CLX-MODIFIER" "MAKE-KEY-EVENT-BITS" "KEY-EVENT-MODIFIER-MASK" "KEY-EVENT-BITS-MODIFIERS" "*ALL-MODIFIER-NAMES*" "TRANSLATE-KEY-EVENT" "TRANSLATE-MOUSE-KEY-EVENT" "MAKE-KEY-EVENT" "KEY-EVENT" "KEY-EVENT-P" "KEY-EVENT-BITS" "KEY-EVENT-KEYSYM" "CHAR-KEY-EVENT" "KEY-EVENT-CHAR" "KEY-EVENT-BIT-P" "DO-ALPHA-KEY-EVENTS" "PRINT-PRETTY-KEY" "PRINT-PRETTY-KEY-EVENT" "*HEMLOCK-VERSION*" "DEFINE-MOUSE-CODE" "DEFINE-KEYBOARD-MODIFIER" "TRANSLATE-CHARACTER" "TRANSLATE-MOUSE-CHARACTER") #+double-double (:export "DOUBLE-DOUBLE-FLOAT" "DD-PI") (:import-from "STREAM" "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "DESCRIBE-EXTERNAL-FORMAT") ;; Unicode (:export "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" "DESCRIBE-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT")) (defpackage "STREAM" (:import-from "SYSTEM" "LISP-STREAM") (:import-from "EXTENSIONS" "FUNDAMENTAL-STREAM") (:import-from "LISP" "LINE-LENGTH" "CHARPOS" "BREF" "BUFFER-COPY" "BUFFER-SAP" "ENDIAN-SWAP-VALUE" "VECTOR-ELT-WIDTH" "SURROGATES" "SURROGATES-TO-CODEPOINT") (:export ;; Stream classes "STREAM" "SIMPLE-STREAM" "SINGLE-CHANNEL-SIMPLE-STREAM" "DUAL-CHANNEL-SIMPLE-STREAM" "STRING-SIMPLE-STREAM" "PROBE-SIMPLE-STREAM" "DIRECT-SIMPLE-STREAM" "BUFFER-INPUT-SIMPLE-STREAM" "BUFFER-OUTPUT-SIMPLE-STREAM" "NULL-SIMPLE-STREAM" "FILE-SIMPLE-STREAM" "MAPPED-FILE-SIMPLE-STREAM" "TERMINAL-SIMPLE-STREAM" "SOCKET-SIMPLE-STREAM" "SOCKET-BASE-SIMPLE-STREAM" "COMPOSING-STREAM" "STRING-INPUT-SIMPLE" "STRING-OUTPUT-SIMPLE-STREAM" "FILL-POINTER-OUTPUT-SIMPLE-STREAM" "XP-SIMPLE-STREAM" "ANNOTATION-OUTPUT-SIMPLE-STREAM" ;; Standard streams "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*ERROR-OUTPUT*" "*QUERY-IO*" "*DEBUG-IO*" "*TRACE-OUTPUT*" "*TERMINAL-IO*" ;; Slot accessors "STREAM-INPUT-HANDLE" "STREAM-OUTPUT-HANDLE" "STREAM-PLIST" ;; Device-level functions "DEVICE-OPEN" "DEVICE-CLOSE" "DEVICE-BUFFER-LENGTH" "DEVICE-FILE-POSITION" "DEVICE-FILE-LENGTH" "DEVICE-READ" "DEVICE-CLEAR-INPUT" "DEVICE-WRITE" "DEVICE-CLEAR-OUTPUT" "DEVICE-EXTEND" "DEVICE-FINISH-RECORD" ;; Implementation functions/macros "DEF-STREAM-CLASS" "WITH-STREAM-CLASS" "SM" "FUNCALL-STM-HANDLER" "FUNCALL-STM-HANDLER-2" "ADD-STREAM-INSTANCE-FLAGS" "REMOVE-STREAM-INSTANCE-FLAGS" "COMPOSE-ENCAPSULATING-STREAMS" ;; User-level functions (mostly reexported from COMMON-LISP) "OPEN" "CLOSE" "READ-BYTE" "READ-CHAR" "READ-NO-HANG-P" "READ-CHAR-NO-HANG" "UNREAD-CHAR" "PEEK-CHAR" "LISTEN" "READ-LINE" "READ-SEQUENCE" "CLEAR-INPUT" "WRITE-BYTE" "WRITE-CHAR" "WRITE-NO-HANG-P" "WRITE-STRING" "WRITE-SEQUENCE" "TERPRI" "FRESH-LINE" "FINISH-OUTPUT" "FORCE-OUTPUT" "CLEAR-OUTPUT" "FILE-POSITION" "FILE-LENGTH" "LINE-LENGTH" "CHARPOS" "STREAM-ELEMENT-TYPE" "STREAM-EXTERNAL-FORMAT" "STREAMP" "OPEN-STREAM-P" "INPUT-STREAM-P" "OUTPUT-STREAM-P" "INTERACTIVE-STREAM-P" "READ-VECTOR" "WRITE-VECTOR" "READ-OCTETS" "WRITE-OCTETS" "WRITE-ALL-OCTETS" "WAIT-FOR-INPUT-AVAILABLE" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "FORMAT" "PPRINT" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "READ" "READ-DELIMITED-LIST" "READ-FROM-STRING" "WRITE" "WRITE-LINE" "WRITE-TO-STRING" "READ-PRESERVING-WHITESPACE" "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT" "+REPLACEMENT-CHARACTER-CODE+" "LIST-ALL-EXTERNAL-FORMATS" "DESCRIBE-EXTERNAL-FORMAT")) (dolist (name '("DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME" "DEBUG-SOURCE-P" "DEBUG-SOURCE-START-POSITIONS")) (intern name "C")) (defpackage "DEBUG-INTERNALS" (:nicknames "DI") (:import-from "C" "DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME" "DEBUG-SOURCE-P" "DEBUG-SOURCE-START-POSITIONS") (:export "*DEBUGGING-INTERPRETER*" "ACTIVATE-BREAKPOINT" "AMBIGUOUS-DEBUG-VARIABLES" "AMBIGUOUS-VARIABLE-NAME" "BREAKPOINT" "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUNCTION" "BREAKPOINT-INFO" "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION" "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUNCTION" "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER" "CODE-LOCATION-P" "CODE-LOCATION-TOP-LEVEL-FORM-OFFSET" "CODE-LOCATION-UNKNOWN-P" "CODE-LOCATION=" "DEACTIVATE-BREAKPOINT" "DEBUG-BLOCK" "DEBUG-BLOCK-ELSEWHERE-P" "DEBUG-BLOCK-P" "DEBUG-BLOCK-SUCCESSORS" "DEBUG-CONDITION" "DEBUG-ERROR" "DEBUG-FUNCTION" "DEBUG-FUNCTION-FUNCTION" "DEBUG-FUNCTION-KIND" "DEBUG-FUNCTION-LAMBDA-LIST" "DEBUG-FUNCTION-NAME" "DEBUG-FUNCTION-P" "DEBUG-FUNCTION-START-LOCATION" "DEBUG-FUNCTION-SYMBOL-VARIABLES" "DEBUG-SOURCE" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME" "DEBUG-SOURCE-P" "DEBUG-SOURCE-ROOT-NUMBER" "DEBUG-SOURCE-START-POSITIONS" "DEBUG-VARIABLE" "DEBUG-VARIABLE-ID" "DEBUG-VARIABLE-INFO-AVAILABLE" "DEBUG-VARIABLE-NAME" "DEBUG-VARIABLE-P" "DEBUG-VARIABLE-PACKAGE" "DEBUG-VARIABLE-SYMBOL" "DEBUG-VARIABLE-VALID-VALUE" "DEBUG-VARIABLE-VALIDITY" "DEBUG-VARIABLE-VALUE" "DELETE-BREAKPOINT" "DELETE-BREAKPOINT-FOR-EDITOR" "DO-BLOCKS" "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUNCTION-BLOCKS" "DO-DEBUG-FUNCTION-VARIABLES" "EVAL-IN-FRAME" "FORM-NUMBER-TRANSLATIONS" "FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION" "FRAME-DEBUG-FUNCTION" "FRAME-DOWN" "FRAME-FUNCTION-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP" "FUNCTION-DEBUG-FUNCTION" "FUNCTION-END-COOKIE-VALID-P" "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE" "LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS" "NO-DEBUG-FUNCTION-RETURNS" "NO-DEBUG-INFO" "PREPROCESS-FOR-EVAL" "RETURN-FROM-FRAME" "SET-BREAKPOINT-FOR-EDITOR" "SET-LOCATION-BREAKPOINT-FOR-EDITOR" "SOURCE-PATH-CONTEXT" "TOP-FRAME" "UNHANDLED-CONDITION" "UNKNOWN-CODE-LOCATION" "UNKNOWN-CODE-LOCATION-P" "UNKNOWN-DEBUG-VARIABLE" "CODE-LOCATION-KIND" "FLUSH-FRAMES-ABOVE" "FIND-DEBUG-TAG-FOR-FRAME")) (dolist (name '("%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET" "%SET-FDEFINITION" "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF" "%SET-SAP-REF-DESCRIPTOR" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE" "%SVSET" "%TYPEP" "SHORT-FLOAT-P" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*")) (intern name "LISP")) (dolist (name '("FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS")) (intern name "SYSTEM")) (defpackage "C" (:nicknames "COMPILER") (:import-from "LISP" "%ARRAY-TYPEP" "%ASET" "%BITSET" "%CHARSET" "%PUT" "%RPLACA" "%RPLACD" "%SBITSET" "%SCHARSET" "%SET-FDEFINITION" "%SET-FILL-POINTER" "%SET-ROW-MAJOR-AREF" "%SET-SAP-REF-DESCRIPTOR" "%SETELT" "%SETNTH" "%SP-STRING-COMPARE" "%SVSET" "%TYPEP" "SHORT-FLOAT-P" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*") (:import-from "SYSTEM" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS") (:import-from "EXTENSIONS" "VARIABLE-INFORMATION" "FUNCTION-INFORMATION" "DECLARATION-INFORMATION" "PARSE-MACRO" "AUGMENT-ENVIRONMENT") (:shadowing-import-from "KERNEL" "CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS" "FIND-CLASS" "CLASS-OF") (:export "%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" "*BACKEND*" "*CODE-SEGMENT*" "*COLLECT-DYNAMIC-STATISTICS*" "*COMPILE-TIME-DEFINE-MACROS*" "*COMPILER-NOTIFICATION-FUNCTION*" "*COMPILING-FOR-INTERPRETER*" "*CONVERTING-FOR-INTERPRETER*" "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*NATIVE-BACKEND*" "*SUPPRESS-VALUES-DECLARATION*" "*TARGET-BACKEND*" "ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE" "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME" "ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME" "ANY" "ARGUMENT-COUNT-ERROR" "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" "ATTRIBUTES=" "BACKEND-ANY-PRIMITIVE-TYPE" "BACKEND-ASSEMBLER-RESOURCES" "BACKEND-BYTE-ORDER" "BACKEND-DISASSEM-PARAMS" "BACKEND-FASL-FILE-IMPLEMENTATION" "BACKEND-FASL-FILE-TYPE" "BACKEND-FASL-FILE-VERSION" "BACKEND-FEATURES" "BACKEND-FOREIGN-LINKAGE-SPACE-START" "BACKEND-FOREIGN-LINKAGE-ENTRY-SIZE" "BACKEND-INFO-ENVIRONMENT" "BACKEND-INSTRUCTION-FLAVORS" "BACKEND-INSTRUCTION-FORMATS" "BACKEND-NAME" "BACKEND-REGISTER-SAVE-PENALTY" "BACKEND-SPECIAL-ARG-TYPES" "BACKEND-VERSION" "BIND" "BRANCH" "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE" "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" "CATCH-BLOCK" "CHECK-CONS" "CHECK-FIXNUM" "CHECK-FUNCTION" "CHECK-FUNCTION-OR-SYMBOL" "CHECK-BIGNUM" "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32" "CLOSURE-INIT" "CLOSURE-REF" "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" "CODE-INSTRUCTIONS" "COERCE-TO-FUNCTION" "COMPILE-FOR-EVAL" "COMPONENT" "COMPONENT-HEADER-LENGTH" "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION" "COMPUTE-OLD-NFP" "COPY-MORE-ARG" "COUNT-ME" "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" "CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE" "DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE" "DEF-IR1-TRANSLATOR" "DEF-PRIMITIVE-TRANSLATOR" "DEF-PRIMITIVE-TYPE" "DEF-PRIMITIVE-TYPE-ALIAS" "DEF-SOURCE-TRANSFORM" "DEF-VM-SUPPORT-ROUTINE" "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION" "DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE" "DEFINE-STORAGE-CLASS" "DEFINE-VOP" "DEFKNOWN" "DEFOPTIMIZER" "DEFTRANSFORM" "DERIVE-TYPE" "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP" "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN" "FASL-FILE-IMPLEMENTATIONS" "FAST-SAFE-COERCE-TO-FUNCTION" "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FLUSHABLE" "FOLDABLE" "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" "GET-VECTOR-SUBTYPE" "HALT" "IF-EQ" "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" "LAMBDA-EVAL-INFO-ARGS-PASSED" "LAMBDA-EVAL-INFO-ENTRIES" "LAMBDA-EVAL-INFO-FRAME-SIZE" "LAMBDA-EVAL-INFO-FUNCTION" "LOCATION=" "LTN-ANNOTATE" "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK" "MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM" "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN" "MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN" "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET" "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" "MAKE-VALUE-CELL" "MAKE-WIRED-TN" "META-PRIMITIVE-TYPE-OR-LOSE" "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE" "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" "MULTIPLE-CALL-VARIABLE" "NIL" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE" "PMAX-FASL-FILE-IMPLEMENTATION" "POLICY" "PPC-FASL-FILE-IMPLEMENTATION" "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF" "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP" "PUSH-VALUES" "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING" "*RECORD-XREF-INFO*" "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE" "RETURN" "RETURN-MULTIPLE" "RT-AFPA-FASL-FILE-IMPLEMENTATION" "RT-FASL-FILE-IMPLEMENTATION" "SAVE-DYNAMIC-STATE" "SB" "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" "SB-P" "SC" "SC-CASE" "SC-IS" "SC-NAME" "SC-NUMBER" "SC-NUMBER-OR-LOSE" "SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB" "SET" "SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE" "SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT" "SPARC-FASL-FILE-IMPLEMENTATION" "SPECIFY-SAVE-TN" "INSTANCE-REF" "INSTANCE-SET" "SXHASH-SIMPLE-STRING" "SXHASH-SIMPLE-SUBSTRING" "SYMBOL-FUNCTION" "SYMBOL-VALUE" "SYMBOLICATE" "TAIL-CALL" "TAIL-CALL-NAMED" "TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE" "THROW" "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR" "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME" "LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET" "FIXUP-P" "MAKE-FIXUP" "SLOT" "X86-FASL-FILE-IMPLEMENTATION" "BACKEND-FEATUREP" "DEF-ALLOC" "BACKEND-ASSEMBLER-PARAMS" "VAR-ALLOC" "BACKEND-INTERNAL-ERRORS" "BACKEND" "SAFE-FDEFN-FUNCTION" "NOTE-FIXUP" "TARGET-FEATUREP" "DEF-REFFER" "NATIVE-FEATUREP" "EMIT-NOP" "DEF-SETTER" "FIXED-ALLOC" "HPPA-FASL-FILE-IMPLEMENTATION" "ALPHA-FASL-FILE-IMPLEMENTATION" "SGI-FASL-FILE-IMPLEMENTATION" "AMD64-FASL-FILE-IMPLEMENTATION" "MAKE-UNBOUND-MARKER" "RETURN-SINGLE" "BACKEND-PAGE-SIZE" "NOTE-NEXT-INSTRUCTION" "SET-SLOT" "LOCATION-NUMBER" "BYTE-FASL-FILE-VERSION" "*COMPILE-COMPONENT*" "BLOCK-NUMBER" "DYNCOUNT-INFO-COUNTS" "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION" "IR2-BLOCK-BLOCK" "DISASSEM-BYTE-COMPONENT" "LITTLE-ENDIAN-FASL-FILE-IMPLEMENTATION" "DYNCOUNT-INFO-COSTS" "FUNCALLABLE-INSTANCE-LEXENV" "DISASSEM-BYTE-FUN" "VOP-BLOCK" "BACKEND-BYTE-FASL-FILE-TYPE" "BIG-ENDIAN-FASL-FILE-IMPLEMENTATION" "*ASSEMBLY-OPTIMIZE*" "LARGE-ALLOC" "%SET-FUNCTION-SELF" "IR2-COMPONENT-DYNCOUNT-INFO" "DYNCOUNT-INFO" "DYNCOUNT-INFO-P" "TRUST-DYNAMIC-EXTENT-DECLARATION-P" "IR2-STACK-ALLOCATE" "%DYNAMIC-EXTENT" "%DYNAMIC-EXTENT-START" "%DYNAMIC-EXTENT-END") ) (defpackage "XREF" (:export "INIT-XREF-DATABASE" "REGISTER-XREF" "WHO-CALLS" "WHO-REFERENCES" "WHO-BINDS" "WHO-SETS" "WHO-SUBCLASSES" "WHO-SUPERCLASSES" "WHO-SPECIALIZES" "WHO-MACROEXPANDS" "MAKE-XREF-CONTEXT" "XREF-CONTEXT-NAME" "XREF-CONTEXT-FILE" "XREF-CONTEXT-SOURCE-PATH" "INVALIDATE-XREFS-FOR-NAMESTRING" "FIND-XREFS-FOR-PATHNAME")) (defpackage "WIRE" (:export "*CURRENT-WIRE*" "CONNECT-TO-REMOTE-SERVER" "CREATE-REQUEST-SERVER" "DESTROY-REQUEST-SERVER" "FORGET-REMOTE-TRANSLATION" "MAKE-REMOTE-OBJECT" "MAKE-WIRE" "REMOTE" "REMOTE-OBJECT" "REMOTE-OBJECT-EQ" "REMOTE-OBJECT-LOCAL-P" "REMOTE-OBJECT-P" "REMOTE-OBJECT-VALUE" "REMOTE-VALUE" "REMOTE-VALUE-BIND" "WIRE-EOF" "WIRE-ERROR" "WIRE-FD" "WIRE-FORCE-OUTPUT" "WIRE-GET-BIGNUM" "WIRE-GET-BYTE" "WIRE-GET-NUMBER" "WIRE-GET-OBJECT" "WIRE-GET-STRING" "WIRE-IO-ERROR" "WIRE-LISTEN" "WIRE-OUTPUT-BIGNUM" "WIRE-OUTPUT-BYTE" "WIRE-OUTPUT-FUNCALL" "WIRE-OUTPUT-NUMBER" "WIRE-OUTPUT-OBJECT" "WIRE-OUTPUT-STRING" "WIRE-P")) (defpackage "PRETTY-PRINT" (:nicknames "PP") (:export "PRETTY-STREAM" "PRETTY-STREAM-P")) (intern "LOAD-FOREIGN" "EXTENSIONS") (defpackage "SYSTEM" (:nicknames "SYS") (:import-from "EXTENSIONS" "LOAD-FOREIGN") (:export "%ASSEMBLER-CODE-TYPE" "%BIND-ALIGNED-SAP" "%PRIMITIVE" "%SP-BYTE-BLT" "%SP-FIND-CHARACTER" "%SP-FIND-CHARACTER-WITH-ATTRIBUTE" "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE" "%STANDARD-CHAR-P" "*BEEP-FUNCTION*" "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" "*SOFTWARE-TYPE*" "*STDERR*" "*STDIN*" "*STDOUT*" "*TASK-DATA*" "*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*" "*XWINDOW-TABLE*" "ADD-FD-HANDLER" "ADD-PORT-DEATH-HANDLER" "ADD-PORT-OBJECT" "ADD-XWINDOW-OBJECT" "ALLOCATE-SYSTEM-MEMORY" "BEEP" "BITS" "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK=" "COMPILER-VERSION" "CT-A-VAL" "CT-A-VAL-OFFSET" "CT-A-VAL-P" "CT-A-VAL-SAP" "CT-A-VAL-SIZE" "CT-A-VAL-TYPE" "DEALLOCATE-SYSTEM-MEMORY" "DEFAULT-INTERRUPT" "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DOUBLE-FLOAT-RADIX" "ENABLE-INTERRUPT" "ENUMERATION" "FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS" "MACRO" "MAKE-CT-A-VAL" "MAKE-FD-STREAM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P" "MAKE-OBJECT-SET" "MAP-PORT" "MAP-XWINDOW" "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "NULL-TERMINATED-STRING" "OBJECT-SET-OPERATION" "OUTPUT-RAW-BYTES" "PARSE-BODY" "PERQ-STRING" "POINTER" "POINTER<" "POINTER>" "PORT" "PRIMEP" "READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE" "REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER" "REMOVE-PORT-OBJECT" "REMOVE-XWINDOW-OBJECT" "RESOLVE-LOADED-ASSEMBLER-REFERENCES" "SAP+" "SAP-" "SAP-INT" "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-8" "SAP-REF-DESCRIPTOR" "SAP-REF-DOUBLE" "SAP-REF-LONG" "SAP-REF-SAP" "SAP-REF-SINGLE" "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>=" "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" "SERVE-EVENT" "SERVER" "SERVER-MESSAGE" "SHORT-FLOAT-RADIX" "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-8" "SINGLE-FLOAT-RADIX" "SYMBOL-MACRO-LET" "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" "VECTOR-SAP" "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS" "WITH-FD-HANDLER" "WITH-INTERRUPTS" "WITH-REPLY-PORT" "WITHOUT-GCING" "WITHOUT-HEMLOCK" "WITHOUT-INTERRUPTS" "WORDS" "OS-INIT" "ALLOCATE-SYSTEM-MEMORY-AT" "ALTERNATE-GET-GLOBAL-ADDRESS" "*RUNTIME-FEATURES*" "REGISTER-LISP-FEATURE" "REGISTER-LISP-RUNTIME-FEATURE" "BINARY-TEXT-STREAM")) (dolist (name '("*" "ARRAY" "BOOLEAN" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT" "SINGLE-FLOAT" "UNION" "VALUES" )) (intern name "LISP")) (defpackage "ALIEN" (:import-from "LISP" "*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION" "BOOLEAN" "INTEGER" "LONG-FLOAT" "SINGLE-FLOAT" "UNION" "VALUES") (:export "*" "ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" "ARRAY" "BOOLEAN" "CAST" "DEF-ALIEN-ROUTINE" "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE" "DEREF" "DOUBLE-FLOAT" "ENUM" "EXTERN-ALIEN" "FUNCTION" "INTEGER" "LONG-FLOAT" "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT" "UNION" "UNSIGNED" "VALUES" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN" "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER" "DEF-CALLBACK" "CALLBACK" "CALLBACK-FUNCALL")) (dolist (name '("%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" "ALIEN-FLOAT-TYPE-P" "ALIEN-FUNCTION-TYPE" "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P" "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE" "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P" "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD" "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET" "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS" "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE" "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE" "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS" "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUE-TYPE" "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA" "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD" "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE" "MAKE-ALIEN-FUNCTION-TYPE" "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN" "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE")) (intern name "ALIEN")) (defpackage "ALIEN-INTERNALS" (:import-from "ALIEN" "%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" "ALIEN-FLOAT-TYPE-P" "ALIEN-FUNCTION-TYPE" "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P" "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE" "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P" "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD" "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET" "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS" "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE" "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE" "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS" "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUE-TYPE" "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA" "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD" "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE" "MAKE-ALIEN-FUNCTION-TYPE" "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN" "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE") (:export "%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN" "ALIEN-ARRAY-TYPE" "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" "ALIEN-FLOAT-TYPE-P" "ALIEN-FUNCTION-TYPE" "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P" "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE" "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P" "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD" "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET" "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS" "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE" "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE" "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS" "ALIEN-TYPE-P" "ALIEN-TYPEP" "ALIEN-VALUE" "ALIEN-VALUE-TYPE" "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P" "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA" "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" "COMPUTE-NATURALIZE-LAMBDA" "DEF-ALIEN-TYPE-CLASS" "DEF-ALIEN-TYPE-METHOD" "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT" "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE" "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN" "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE" "MAKE-ALIEN-FUNCTION-TYPE" "MAKE-ALIEN-POINTER-TYPE" "MAKE-LOCAL-ALIEN" "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE" "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE")) (defpackage "PROFILE" (:export "*DEFAULT-REPORT-TIME-PRINTFUNCTION*" "*INSERT-SPACEREPORTS*" "*TIMED-FUNCTIONS*" "DELETE-SPACEREPORTS" "PRINT-SPACEREPORTS" "PROFILE" "PROFILE-ALL" "REPORT-TIME" "REPORT-TIME-CUSTOM" "RESET-SPACEREPORTS" "RESET-TIME" "UNPROFILE" "WITH-SPACEREPORT" "*NO-CALLS-LIMIT*" "*NO-CALLS*")) (dolist (name '("ARRAY-RANK" "ARRAY-TOTAL-SIZE" "BOOLEAN" "CHAR-INT" "FLOAT-DIGITS" "FLOAT-RADIX" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION")) (intern name "LISP")) (intern "VOID" "C-CALL") (defpackage "KERNEL" (:import-from "LISP" "BOOLEAN") (:import-from "C-CALL" "VOID") (:import-from "CONDITIONS" "PARSE-UNKNOWN-TYPE-SPECIFIER") (:shadow "CLASS" "STRUCTURE-CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "FIND-CLASS" "CLASS-OF") (:export "%CLASS-LAYOUT" "%CLASS-STATE" "%CLASS-DIRECT-SUPERCLASSES" "%CLASS-SUBCLASSES" "%CLASS-PCL-CLASS" "%CLASS-NAME" "RED-ZONE-HIT" "YELLOW-ZONE-HIT" "STACK-OVERFLOW" "*ANSI-DEFSTRUCT-OPTIONS-P*" "%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION" "%CLOSURE-INDEX-REF" "%COS" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LOG2" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" "%MASK-FIELD" "%NEGATE" "%POW" "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG" "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE" "%RAW-REF-LONG" "%RAW-REF-SINGLE" "%RAW-SET-COMPLEX-DOUBLE" "%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE" "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION" "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS" "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-LONG" "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE" "%SET-SIGNED-SAP-REF-16" "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64" "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF" "%SIN" "%SET-SYMBOL-HASH" "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION" "%SP-SET-PLIST" "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TANH" "%UNARY-ROUND" "%UNARY-FROUND/SINGLE-FLOAT" "%UNARY-FROUND/DOUBLE-FLOAT" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE" "%UNARY-FTRUNCATE/SINGLE-FLOAT" "%UNARY-FTRUNCATE/DOUBLE-FLOAT" "%WITH-ARRAY-DATA" "*CURRENT-LEVEL*" "*EMPTY-TYPE*" "*EVAL-STACK-TOP*" "*NULL-TYPE*" "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*" "*UNPARSE-FUNCTION-TYPE-SIMPLIFY*" "*WILD-TYPE*" "32BIT-LOGICAL-AND" "32BIT-LOGICAL-ANDC1" "32BIT-LOGICAL-ANDC2" "32BIT-LOGICAL-EQV" "32BIT-LOGICAL-NAND" "32BIT-LOGICAL-NOR" "32BIT-LOGICAL-NOT" "32BIT-LOGICAL-OR" "32BIT-LOGICAL-ORC1" "32BIT-LOGICAL-ORC2" "32BIT-LOGICAL-XOR" "ALIEN-TYPE-TYPE" "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" "ALLOCATE-VECTOR" "ALWAYS-SUBTYPEP" "ARGS-TYPE" "ARGS-TYPE-ALLOWP" "ARGS-TYPE-KEYP" "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P" "ARGS-TYPE-REQUIRED" "ARGS-TYPE-REST" "ARRAY-HEADER-P" "ARRAY-RANK" "ARRAY-TOTAL-SIZE" "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP" "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" "ARRAY-TYPE-P" "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX" "BASE-CHAR-P" "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX" "BYTE-BASH-COPY" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE" "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT" "SEQUENCE-COUNT" "CHECK-FOR-CIRCULARITY" "CODE-COMPONENT" "CODE-COMPONENT-P" "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-INSTRUCTIONS" "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P" "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P" "CONSED-SEQUENCE" "CONSTANT-MODIFIED" "CONSTANT-TYPE" "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE" "CONS-TYPE" "CONS-TYPE-CAR-TYPE" "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P" "CONTAINING-INTEGER-TYPE" "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA" "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA" "CSUBTYPEP" "CTYPE" "CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP" "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT" "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR" "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-BITS" "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME" "FLOAT-DIGITS" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-MAX" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P" "FUNCTION-CODE-HEADER" "FUNCTION-TYPE" "FUNCTION-TYPE-ALLOWP" "FUNCTION-TYPE-KEYP" "FUNCTION-TYPE-KEYWORDS" "FUNCTION-TYPE-NARGS" "FUNCTION-TYPE-OPTIONAL" "FUNCTION-TYPE-P" "FUNCTION-TYPE-REQUIRED" "FUNCTION-TYPE-REST" "FUNCTION-TYPE-RETURNS" "FUNCTION-TYPE-WILD-ARGS" "FUNCTION-WORD-OFFSET" "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" "GET-LISP-OBJ-ADDRESS" "GET-LOWTAG" "GET-TYPE" "HAIRY-TYPE" "HAIRY-TYPE-CHECK-TEMPLATE" "HAIRY-TYPE-SPECIFIER" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" "INTERSECTION-TYPE" "INTERSECTION-TYPE-TYPES" "HANDLE-CIRCULARITY" "INDEX" "INIT-RANDOM-STATE" "INTEGER-DECODE-DOUBLE-FLOAT" "INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-TIME" "INVALID-ARGUMENT-COUNT-ERROR" "INVALID-ARRAY-INDEX-ERROR" "INVALID-UNWIND-ERROR" "IRRATIONAL" "KEY-INFO" "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" "LAYOUT-INVALID-ERROR" "LEXICAL-ENVIRONMENT" "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" "LONG-FLOAT-HIGH-BITS" "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P" "LRA" "LRA-CODE-HEADER" "LRA-P" "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE" "MAKE-ARRAY-HEADER" "MAKE-CONS-TYPE" "MAKE-DOUBLE-FLOAT" "MAKE-FUNCTION-TYPE" "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT" "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "%MAKE-INSTANCE" "MAKE-UNION-TYPE" "MAKE-VALUES-TYPE" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS" "MUTATOR-SELF" "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P" "NATIVE-BYTE-ORDER" "NEGATE" "NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR" "NOT-<=-ERROR" "NOT-=-ERROR" "NUMERIC-CONTAGION" "NUMERIC-TYPE" "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" "NUMERIC-TYPE-FORMAT" "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR" "OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR" "OBJECT-NOT-COERCABLE-TO-FUNCTION-ERROR" "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-COMPLEX-FLOAT-ERROR" "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR" "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR" "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-COMPLEX-RATIONAL-ERROR" "OBJECT-NOT-CONS-ERROR" "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR" "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR" "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR" "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-INTEGER-ERROR" "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR" "OBJECT-NOT-NUMBER-ERROR" "OBJECT-NOT-RATIO-ERROR" "OBJECT-NOT-RATIONAL-ERROR" "OBJECT-NOT-REAL-ERROR" "OBJECT-NOT-SAP-ERROR" "OBJECT-NOT-SIGNED-BYTE-32-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-LONG-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-4-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-8-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-16-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-30-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR" "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR" "OBJECT-NOT-SIMPLE-STRING-ERROR" "OBJECT-NOT-SIMPLE-VECTOR-ERROR" "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR" "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-SYMBOL-ERROR" "OBJECT-NOT-TYPE-ERROR" "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR" "OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR" "ODD-KEYWORD-ARGUMENTS-ERROR" "ORDER-LAYOUT-INHERITS" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMELIKE" "PUNT-IF-TOO-LONG" "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT" "SCALE-SINGLE-FLOAT" "SEQUENCE-END" "SET-HEADER-DATA" "SHIFT-TOWARDS-END" "SHIFT-TOWARDS-START" "SIGNAL-INIT" "SIGNED-BYTE-32-P" "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P" "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-P" "SIMPLE-ARRAY-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SIMPLE-ARRAY-SINGLE-FLOAT-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P" "SIMPLE-ARRAY-SIGNED-BYTE-16-P" "SIMPLE-ARRAY-SIGNED-BYTE-30-P" "SIMPLE-ARRAY-SIGNED-BYTE-32-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" "SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF" "STD-COMPUTE-CLASS-PRECEDENCE-LIST" "STREAMLIKE" "SIMPLE-STREAM-BUFFER" "STRINGABLE" "STRINGLIKE" "%INSTANCE-LENGTH" "%INSTANCE-REF" "%INSTANCE-SET" "SYSTEM-AREA-CLEAR" "SYSTEM-AREA-COPY" "TRUTH" "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-GCD" "TWO-ARG-IOR" "TWO-ARG-LCM" "TWO-ARG-XOR" "TYPE-DIFFERENCE" "TYPE-EXPAND" "TYPE-INIT" "TYPE-INTERSECT" "TYPE-INTERSECTION" "TYPE-SPECIFIER" "TYPE-SPECIFIER-SYMBOLS" "TYPE-UNION" "TYPE/=" "TYPE=" "TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" "UNDEFINED-SYMBOL-ERROR" "UNDEFINED-FOREIGN-SYMBOL-ERROR" "UNDEFINED-FOREIGN-SYMBOL-ERROR-HANDLER" "UNION-TYPE" "UNION-TYPE-P" "UNION-TYPE-TYPES" "UNKNOWN-ERROR" "UNKNOWN-KEYWORD-ARGUMENT-ERROR" "UNKNOWN-TYPE" "UNKNOWN-TYPE-P" "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR" "UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE" "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" "VALUES-TYPE" "VALUES-TYPE-ALLOWP" "VALUES-TYPE-INTERSECT" "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP" "VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VOID" "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR" "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUNCTION" "FDEFN-OR-LOSE" "FDEFN-MAKUNBOUND" "%COERCE-TO-FUNCTION" "FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT" "FIND-CALLER-NAME" "OLD-IN-PACKAGE" "%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE" "OUTPUT-SYMBOL-NAME" "FSET" "RAW-DEFINITION" "%IN-PACKAGE" "%DEFPACKAGE" "INVOKE-MACROEXPAND-HOOK" "TYPEDEF-INIT" "DEFAULT-STRUCTURE-PRINT" "LAYOUT" "LAYOUT-LENGTH" "RATIOP" "FIXNUMP" "LAMBDA-WITH-ENVIRONMENT" "LAYOUT-PURE" "DSD-RAW-TYPE" "%COMPILER-DEFSTRUCT" "DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE" "BIGNUMP" "DD-COPIER" "UNDEFINE-FUNCTION-NAME" "DD-TYPE" "CLASS-STATE" "INSTANCE" "*TYPE-SYSTEM-INITIALIZED*" "WEAK-POINTER-P" "FIND-LAYOUT" "DSD-NAME" "%TYPEP" "DD-RAW-INDEX" "DD-NAME" "CLASS-SUBCLASSES" "CLASS-LAYOUT" "DD-RAW-LENGTH" "NOTE-NAME-DEFINED" "%CODE-CODE-SIZE" "DD-SLOTS" "%IMAGPART" "DSD-ACCESSOR" "CLASS-INIT" "%CODE-DEBUG-INFO" "DSD-%NAME" "LAYOUT-CLASS" "LAYOUT-INVALID" "%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION" "MAKE-STRUCTURE-LOAD-FORM" "BITP" "%FUNCTION-ARGLIST" "%FUNCTION-NEXT" "LAYOUT-HASH-LENGTH" "DD-PREDICATE" "CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO" "%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR" "LAYOUT-OF" "%FUNCTION-SELF" "%REALPART" "STRUCTURE-CLASS-P" "DSD-INDEX" "%INSTANCE-LAYOUT" "LAYOUT-HASH" "%FUNCTION-TYPE" "DEFINE-FUNCTION-NAME" "LAYOUT-INHERITANCE-DEPTH" "%%COMPILER-DEFSTRUCT" "%NUMERATOR" "CLASS-TYPEP" "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY" "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS" "STRUCTURE-CLASS-MAKE-LOAD-FORM-FUN" "%DENOMINATOR" "BYTE-FUNCTION-OR-CLOSURE" "MAKE-STANDARD-CLASS" "BYTE-FUNCTION-NAME" "CLASS-CELL-TYPEP" "BYTE-CLOSURE" "FIND-CLASS-CELL" "EXTRACT-FUNCTION-TYPE" "FUNCALLABLE-STRUCTURE-CLASS" "%RANDOM-DOUBLE-FLOAT" "%RANDOM-LONG-FLOAT" "%RANDOM-SINGLE-FLOAT" "RANDOM-PCL-CLASS" "BASIC-STRUCTURE-CLASS-PRINT-FUNCTION" "%FUNCALLABLE-INSTANCE-INFO" "*EVAL-STACK*" "RANDOM-CHUNK" "MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-HASH-MAX" "CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES" "INITIALIZE-BYTE-COMPILED-FUNCTION" "INITIALIZE-LAYOUT-HASH" "CLASS-PCL-CLASS" "FUNCALLABLE-STRUCTURE" "FUNCALLABLE-INSTANCE-FUNCTION" "%FUNCALLABLE-INSTANCE-LAYOUT" "BASIC-STRUCTURE-CLASS" "BYTE-CLOSURE-DATA" "BYTE-CLOSURE-FUNCTION" "BYTE-FUNCTION" "CLASS-CELL-CLASS" "FUNCALLABLE-STRUCTURE-CLASS-P" "REGISTER-LAYOUT" "FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX" "MAKE-RANDOM-PCL-CLASS" "INSTANCE-LAMBDA" "%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL" "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH" "MAKE-UNDEFINED-CLASS" "%COMPILER-ONLY-DEFSTRUCT" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING" "SIMPLE-UNDEFINED-FUNCTION" "SIMPLE-PARSE-ERROR" "SIMPLE-STREAM-ERROR" "BYTE-FUNCTION-TYPE" "SLOT-CLASS-PRINT-FUNCTION" "REDEFINE-LAYOUT-WARNING" "SLOT-CLASS" "INSURED-FIND-CLASS" "CONDITION-FUNCTION-NAME" "%COMPLEX-SINGLE-FLOAT" "%COMPLEX-DOUBLE-FLOAT" "%COMPLEX-DOUBLE-DOUBLE-FLOAT" "STANDARD-READTABLE-MODIFIED-ERROR" "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" "%IEEE754-REM-PI/2" "%SINCOS") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" "HEAP-OVERFLOW") #+X86 (:export "ATOMIC-PUSH-VECTOR" "RPLACD-CONDITIONAL" "ATOMIC-PUSH-SYMBOL-VALUE" "DATA-VECTOR-SET-CONDITIONAL" "RPLACA-CONDITIONAL" "%INSTANCE-SET-CONDITIONAL" "SET-SYMBOL-VALUE-CONDITIONAL" "ATOMIC-POP-SYMBOL-VALUE" "ATOMIC-PUSHA" "ATOMIC-PUSHD") #+x87 (:export "%COS-QUICK" "%SIN-QUICK" "%TAN-QUICK") ;;#+double-double (:export "DOUBLE-DOUBLE-FLOAT" "DOUBLE-DOUBLE-FLOAT-P" "DOUBLE-DOUBLE-HI" "DOUBLE-DOUBLE-LO" "MAKE-DOUBLE-DOUBLE-FLOAT" "%MAKE-DOUBLE-DOUBLE-FLOAT" "%DOUBLE-DOUBLE-FLOAT" "OBJECT-NOT-DOUBLE-DOUBLE-FLOAT-ERROR" "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-ERROR" "COMPLEX-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" "DD-PI" "INVALID-CASE")) (dolist (name '("BRANCH" "FLUSHABLE" "SSET-ELEMENT" "SSET" "MAKE-SSET" "DO-ELEMENTS" "SSET-ADJOIN" "SSET-DELETE" "SSET-EMPTY")) (intern name "C")) (defpackage "NEW-ASSEM" (:import-from "C" "BRANCH" "FLUSHABLE" "SSET-ELEMENT" "SSET" "MAKE-SSET" "DO-ELEMENTS" "SSET-ADJOIN" "SSET-DELETE" "SSET-EMPTY") (:export "EMIT-BYTE" "EMIT-SKIP" "EMIT-BACK-PATCH" "EMIT-CHOOSER" "DEFINE-EMITTER" "DEFINE-INSTRUCTION" "DEFINE-INSTRUCTION-MACRO" "DEF-ASSEMBLER-PARAMS" "EMIT-POSTIT" "MAKE-SEGMENT" "SEGMENT-NAME" "ASSEMBLE" "ALIGN" "INST" "LABEL" "LABEL-P" "GEN-LABEL" "EMIT-LABEL" "LABEL-POSITION" "APPEND-SEGMENT" "FINALIZE-SEGMENT" "SEGMENT-MAP-OUTPUT" "RELEASE-SEGMENT" "READS" "WRITES" "SEGMENT" "WITHOUT-SCHEDULING" "BRANCH" "FLUSHABLE" "VARIABLE-LENGTH" "SEGMENT-COLLECT-DYNAMIC-STATISTICS")) (defpackage "MULTIPROCESSING" (:use "COMMON-LISP") (:nicknames "MP") (:export "*ALL-PROCESSES*" "*CURRENT-PROCESS*" "*CURRENT-STACK-GROUP*" "*INITIAL-STACK-GROUP*" "*MULTI-PROCESSING*" "ALL-PROCESSES" "ATOMIC-DECF" "ATOMIC-INCF" "ATOMIC-POP" "ATOMIC-PUSH" "CURRENT-PROCESS" "DESTROY-PROCESS" "DISABLE-PROCESS" "ENABLE-PROCESS" "INIT-STACK-GROUPS" "LOCK" "MAKE-STACK-GROUP" "MAKE-LOCK" "MAKE-PROCESS" "PROCESS-ACTIVE-P" "PROCESS-JOIN" "PROCESS-ADD-ARREST-REASON" "PROCESS-ADD-RUN-REASON" "PROCESS-ALIVE-P" "PROCESS-ARREST-REASONS" "PROCESS-IDLE-TIME" "PROCESS-INTERRUPT" "PROCESS-NAME" "PROCESS-PRESET" "PROCESS-PROPERTY-LIST" "PROCESS-REAL-TIME" "PROCESS-REVOKE-ARREST-REASON" "PROCESS-REVOKE-RUN-REASON" "PROCESS-RUN-REASONS" "PROCESS-RUN-TIME" "PROCESS-STATE" "PROCESS-WAIT-UNTIL-FD-USABLE" "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT" "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP" "RESTART-PROCESS" "SHOW-PROCESSES" "STACK-GROUP-RESUME" "WITHOUT-SCHEDULING" "WITH-LOCK-HELD" "WITH-TIMEOUT")) (defpackage "WALKER" (:use "COMMON-LISP" "EXT") (:export "DEFINE-WALKER-TEMPLATE" "WALK-FORM" "WALK-FORM-EXPAND-MACROS-P" "NESTED-WALK-FORM" "VARIABLE-LEXICAL-P" "VARIABLE-SPECIAL-P" "VARIABLE-GLOBALLY-SPECIAL-P" "*VARIABLE-DECLARATIONS*" "VARIABLE-DECLARATION" "MACROEXPAND-ALL")) (defpackage "FWRAPPERS" (:use "COMMON-LISP" "EXT" "KERNEL") (:export "DEFINE-FWRAPPER" "FWRAPPER" "CALL-NEXT-FUNCTION" "FWRAP" "FUNWRAP" "FIND-FWRAPPER" "FWRAPPER-TYPE" "FWRAPPER-NEXT" "FWRAPPER-USER-DATA" "FWRAPPER-CONSTRUCTOR" "UPDATE-FWRAPPER" "UPDATE-FWRAPPERS" "SET-FWRAPPERS" "LIST-FWRAPPERS" "PUSH-FWRAPPER" "DELETE-FWRAPPER" "LAST-FWRAPPER" "DO-FWRAPPERS")) (defpackage "UNICODE" (:use "COMMON-LISP") (:shadow "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE") (:import-from "LISP" "CODEPOINT" "SURROGATES" "UNICODE-FULL-CASE-LOWER" "UNICODE-FULL-CASE-UPPER" "UNICODE-FULL-CASE-TITLE" "UNICODE-CATEGORY" "+UNICODE-CATEGORY-LOWER+" "+UNICODE-CATEGORY-OTHER+" "+UNICODE-CATEGORY-GRAPHIC+" "+UNICODE-CATEGORY-UPPER+" "+UNICODE-CATEGORY-TITLE+" "UNICODE-UPPER" "UNICODE-WORD-BREAK") (:export "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE" "STRING-NEXT-WORD-BREAK")) cmucl-21a/src/code/extensions.lisp000066400000000000000000000506501260377556400173600ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Extensions -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/extensions.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Spice Lisp extensions to the language. ;;; ;;; Letf written by Steven Handerson. ;;; ;;; ********************************************************************** (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(letf* letf dovector deletef indenting-further file-comment read-char-no-edit listen-skip-whitespace concat-pnames iterate once-only collect do-anonymous undefined-value required-argument define-hash-cache defun-cached cache-hash-eq do-hash)) (import 'lisp::whitespace-char-p) ;;; Undefined-Value -- Public ;;; ;;; This is here until we figure out what to do with it. ;;; (declaim (inline undefined-value)) (defun undefined-value () '%undefined%) ;;; REQUIRED-ARGUMENT -- Public ;;; (declaim (ftype (function () nil) required-argument)) (defun required-argument () "This function can be used as the default value for keyword arguments that must be always be supplied. Since it is known by the compiler to never return, it will avoid any compile-time type warnings that would result from a default value inconsistent with the declared type. When this function is called, it signals an error indicating that a required keyword argument was not supplied. This function is also useful for DEFSTRUCT slot defaults corresponding to required arguments." (error (intl:gettext "A required keyword argument was not supplied."))) ;;; FILE-COMMENT -- Public ;;; (defmacro file-comment (string) "FILE-COMMENT String When COMPILE-FILE sees this form at top-level, it places the constant string in the run-time source location information. DESCRIBE will print the file comment for the file that a function was defined in. The string is also textually present in the FASL, so the RCS \"ident\" command can find it, etc." (declare (ignore string)) '(undefined-value)) (defun skip-whitespace (&optional (stream *standard-input*)) (loop (let ((char (read-char stream))) (if (not (lisp::whitespacep char)) (return (unread-char char stream)))))) (defun listen-skip-whitespace (&optional (stream *standard-input*)) "See listen. Any whitespace in the input stream will be flushed." (do ((char (read-char-no-hang stream nil nil nil) (read-char-no-hang stream nil nil nil))) ((null char) nil) (cond ((not (whitespace-char-p char)) (unread-char char stream) (return T))))) ;;; These macros waste time as opposed to space. (defmacro letf* (bindings &body body &environment env) "Does what one might expect, saving the old values and setting the generalized variables to the new values in sequence. Unwind-protects and get-setf-method are used to preserve the semantics one might expect in analogy to let*, and the once-only evaluation of subforms." (labels ((do-bindings (bindings) (cond ((null bindings) body) (t (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (caar bindings) env) (let ((save (gensym))) `((let* (,@(mapcar #'list dummies vals) (,(car newval) ,(cadar bindings)) (,save ,getter)) (unwind-protect (progn ,setter ,@(do-bindings (cdr bindings))) (setq ,(car newval) ,save) ,setter))))))))) (car (do-bindings bindings)))) (defmacro letf (bindings &body body &environment env) "Like letf*, but evaluates all the implicit subforms and new values of all the implied setfs before altering any values. However, the store forms (see get-setf-method) must still be evaluated in sequence. Uses unwind- protects to protect the environment." (let (temps) (labels ((do-bindings (bindings) (cond ((null bindings) body) (t (let ((binding (car bindings))) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (car binding) env) (let ((save (gensym))) (mapcar #'(lambda (a b) (push (list a b) temps)) dummies vals) (push (list save getter) temps) (push (list (car newval) (cadr binding)) temps) `((unwind-protect (progn ,setter ,@(do-bindings (cdr bindings))) (setq ,(car newval) ,save) ,setter))))))))) (let ((form (car (do-bindings bindings)))) `(let* ,(nreverse temps) ,form))))) (define-setf-expander logbitp (index int &environment env) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int env) (let ((ind (gensym)) (store (gensym)) (stemp (first stores))) (values `(,ind ,@temps) `(,index ,@vals) (list store) `(let ((,stemp (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) ,store-form ,store) `(logbitp ,ind ,access-form))))) ;;; Indenting-Further is a user-level macro which may be used to locally increment ;;; the indentation of a stream. (defmacro indenting-further (stream more &rest body) "Causes the output of the indenting Stream to indent More spaces. More is evaluated twice." `(unwind-protect (progn (incf (lisp::indenting-stream-indentation ,stream) ,more) ,@body) (decf (lisp::indenting-stream-indentation ,stream) ,more))) ;;; Deletef (defmacro deletef (elt list &rest keys &environment env) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method list env) (let ((eltsym (gensym)) (listsym (gensym))) `(let* ((,eltsym ,elt) ,@(mapcar #'list dummies vals) (,listsym ,getter) (,(car newval) (delete ,eltsym ,listsym ,@keys))) ,setter)))) (defmacro dovector ((elt vector &optional default) &rest forms) "Just like dolist, but with one-dimensional arrays." (let ((index (gensym)) (length (gensym)) (vec (gensym))) `(let ((,vec ,vector)) (do ((,index 0 (1+ ,index)) (,length (length ,vec))) ((>= ,index ,length) ,default) (let ((,elt (aref ,vec ,index))) ,@forms))))) (eval-when (compile load eval) (defun concat-pnames (name1 name2) (declare (symbol name1 name2)) (if name1 (intern (concatenate 'simple-string (symbol-name name1) (symbol-name name2))) name2))) ;;; Iterate -- Public ;;; ;;; The ultimate iteration macro... ;;; (defmacro iterate (name binds &body body) "Iterate Name ({(Var Initial-Value)}*) Declaration* Form* This is syntactic sugar for Labels. It creates a local function Name with the specified Vars as its arguments and the Declarations and Forms as its body. This function is then called with the Initial-Values, and the result of the call is return from the macro." (dolist (x binds) (unless (and (listp x) (= (length x) 2)) (error (intl:gettext "Malformed iterate variable spec: ~S.") x))) `(labels ((,name ,(mapcar #'first binds) ,@body)) (,name ,@(mapcar #'second binds)))) ;;;; The Collect macro: ;;; Collect-Normal-Expander -- Internal ;;; ;;; This function does the real work of macroexpansion for normal collection ;;; macros. N-Value is the name of the variable which holds the current ;;; value. Fun is the function which does collection. Forms is the list of ;;; forms whose values we are supposed to collect. ;;; (defun collect-normal-expander (n-value fun forms) `(progn ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) ,n-value)) ;;; Collect-List-Expander -- Internal ;;; ;;; This function deals with the list collection case. N-Tail is the pointer ;;; to the current tail of the list, which is NIL if the list is empty. ;;; (defun collect-list-expander (n-value n-tail forms) (let ((n-res (gensym))) `(progn ,@(mapcar #'(lambda (form) `(let ((,n-res (cons ,form nil))) (cond (,n-tail (setf (cdr ,n-tail) ,n-res) (setq ,n-tail ,n-res)) (t (setq ,n-tail ,n-res ,n-value ,n-res))))) forms) ,n-value))) ;;; Collect -- Public ;;; ;;; The ultimate collection macro... ;;; (defmacro collect (collections &body body) "Collect ({(Name [Initial-Value] [Function])}*) {Form}* Collect some values somehow. Each of the collections specifies a bunch of things which collected during the evaluation of the body of the form. The name of the collection is used to define a local macro, a la MACROLET. Within the body, this macro will evaluate each of its arguments and collect the result, returning the current value after the collection is done. The body is evaluated as a PROGN; to get the final values when you are done, just call the collection macro with no arguments. Initial-Value is the value that the collection starts out with, which defaults to NIL. Function is the function which does the collection. It is a function which will accept two arguments: the value to be collected and the current collection. The result of the function is made the new value for the collection. As a totally magical special-case, the Function may be Collect, which tells us to build a list in forward order; this is the default. If an Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the end. Note that Function may be anything that can appear in the functional position, including macros and lambdas." (let ((macros ()) (binds ())) (dolist (spec collections) (unless (<= 1 (length spec) 3) (error (intl:gettext "Malformed collection specifier: ~S.") spec)) (let ((n-value (gensym)) (name (first spec)) (default (second spec)) (kind (or (third spec) 'collect))) (push `(,n-value ,default) binds) (if (eq kind 'collect) (let ((n-tail (gensym))) (if default (push `(,n-tail (last ,n-value)) binds) (push n-tail binds)) (push `(,name (&rest args) (collect-list-expander ',n-value ',n-tail args)) macros)) (push `(,name (&rest args) (collect-normal-expander ',n-value ',kind args)) macros)))) `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) ;;;; The Once-Only macro: ;;; Once-Only -- Interface ;;; ;;; Once-Only is a utility useful in writing source transforms and macros. ;;; It provides an easy way to wrap a let around some code to ensure that some ;;; forms are only evaluated once. ;;; (defmacro once-only (specs &body body) "Once-Only ({(Var Value-Expression)}*) Form* Create a Let* which evaluates each Value-Expression, binding a temporary variable to the result, and wrapping the Let* around the result of the evaluation of Body. Within the body, each Var is bound to the corresponding temporary variable." (iterate frob ((specs specs) (body body)) (if (null specs) `(progn ,@body) (let ((spec (first specs))) (when (/= (length spec) 2) (error (intl:gettext "Malformed Once-Only binding spec: ~S.") spec)) (let ((name (first spec)) (exp-temp (gensym))) `(let ((,exp-temp ,(second spec)) (,name (gensym "OO-"))) `(let ((,,name ,,exp-temp)) ,,(frob (rest specs) body)))))))) ;;;; DO-ANONYMOUS: ;;; ### Bootstrap hack... Renamed to avoid clobbering function in bootstrap ;;; environment. ;;; (defun lisp::do-do-body (varlist endlist code decl bind step name block) (let* ((inits ()) (steps ()) (l1 (gensym)) (l2 (gensym))) ;; Check for illegal old-style do. (when (or (not (listp varlist)) (atom endlist)) (error (intl:gettext "Ill-formed ~S -- possibly illegal old style DO?") name)) ;; Parse the varlist to get inits and steps. (dolist (v varlist) (cond ((symbolp v) (push v inits)) ((listp v) (unless (symbolp (first v)) (error (intl:gettext "~S step variable is not a symbol: ~S") name (first v))) (case (length v) (1 (push (first v) inits)) (2 (push v inits)) (3 (push (list (first v) (second v)) inits) (setq steps (list* (third v) (first v) steps))) (t (error (intl:gettext "~S is an illegal form for a ~S varlist.") v name)))) (t (error (intl:gettext "~S is an illegal form for a ~S varlist.") v name)))) ;; And finally construct the new form. `(block ,BLOCK (,bind ,(nreverse inits) ,@decl (tagbody (go ,L2) ,L1 ,@code (,step ,@(nreverse steps)) ,L2 (unless ,(car endlist) (go ,L1)) (return-from ,BLOCK (progn ,@(cdr endlist)))))))) (defmacro do-anonymous (varlist endlist &parse-body (body decls)) "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Like DO, but has no implicit NIL block. Each Var is initialized in parallel to the value of the specified Init form. On subsequent iterations, the Vars are assigned the value of the Step form (if any) in paralell. The Test is evaluated before each evaluation of the body Forms. When the Test is true, the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO." (lisp::do-do-body varlist endlist body decls 'let 'psetq 'do-anonymous (gensym))) (defmacro do-hash ((key-var value-var table &optional result) &parse-body (body decls)) "DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form* Iterate over the entries in a hash-table." (let ((gen (gensym)) (n-more (gensym))) `(with-hash-table-iterator (,gen ,table) (loop (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) ,@decls (unless ,n-more (return ,result)) ,@body))))) ;;;; Hash cache utility: (eval-when (compile load eval) (defvar *profile-hash-cache* nil)) ;;; DEFINE-HASH-CACHE -- Public ;;; ;;; :INIT-FORM passed as COLD-LOAD-INIT in type system definitions so that ;;; caches can be created before top-level forms run. ;;; (defmacro define-hash-cache (name args &key hash-function hash-bits default (init-form 'progn) (values 1)) "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}* Define a hash cache that associates some number of argument values to a result value. The Test-Function paired with each Arg-Name is used to compare the value for that arg in a cache entry with a supplied arg. The Test-Function must not error when passed NIL as its first arg, but need not return any particular value. Test-Function may be any thing that can be place in CAR position. Name is used to define functions these functions: -CACHE-LOOKUP Arg* See if there is an entry for the specified Args in the cache. The if not present, the :DEFAULT keyword (default NIL) determines the result(s). -CACHE-ENTER Arg* Value* Encache the association of the specified args with Value. -CACHE-FLUSH- Arg Flush all entries from the cache that have the value Arg for the named arg. -CACHE-CLEAR Reinitialize the cache, invalidating all entries and allowing the arguments and result values to be GC'd. These other keywords are defined: :HASH-BITS The size of the cache as a power of 2. :HASH-FUNCTION function Some thing that can be placed in CAR position which will compute a value between 0 and (1- (expt 2 )). :VALUES The number of values cached. :INIT-FORM The DEFVAR for creating the cache is enclosed in a form with the specified name. Default PROGN." (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) (nargs (length args)) (entry-size (+ nargs values)) (size (ash 1 hash-bits)) (total-size (* entry-size size)) (default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) (n-index (gensym)) (n-cache (gensym))) (unless (= (length default-values) values) (error (intl:gettext "Number of default values ~S differs from :VALUES ~D.") default values)) (collect ((inlines) (forms) (inits) (tests) (sets) (arg-vars) (values-indices) (values-names)) (dotimes (i values) (values-indices `(+ ,n-index ,(+ nargs i))) (values-names (gensym))) (let ((n 0)) (dolist (arg args) (unless (= (length arg) 2) (error (intl:gettext "Bad arg spec: ~S.") arg)) (let ((arg-name (first arg)) (test (second arg))) (arg-vars arg-name) (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name)) (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)) (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name))) (forms `(defun ,fun-name (,arg-name) (sys:without-interrupts (do ((,n-index ,(+ (- total-size entry-size) n) (- ,n-index ,entry-size)) (,n-cache ,var-name)) ((minusp ,n-index)) (declare (type fixnum ,n-index)) (when (,test (svref ,n-cache ,n-index) ,arg-name) (let ((,n-index (- ,n-index ,n))) ,@(mapcar #'(lambda (i val) `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)))) (values)))))) (incf n))) (when *profile-hash-cache* (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*")) (n-miss (symbolicate "*" name "-CACHE-MISSES*"))) (inits `(setq ,n-probe 0)) (inits `(setq ,n-miss 0)) (forms `(defvar ,n-probe)) (forms `(defvar ,n-miss)) (forms `(declaim (fixnum ,n-miss ,n-probe))))) (let ((fun-name (symbolicate name "-CACHE-LOOKUP"))) (inlines fun-name) (forms `(defun ,fun-name ,(arg-vars) (sys:without-interrupts ,@(when *profile-hash-cache* `((incf ,(symbolicate "*" name "-CACHE-PROBES*")))) (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) (,n-cache ,var-name)) (declare (type fixnum ,n-index)) (cond ((and ,@(tests)) (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x)) (values-indices)))) (t ,@(when *profile-hash-cache* `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) ,default))))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) (inlines fun-name) (forms `(defun ,fun-name (,@(arg-vars) ,@(values-names)) (sys:without-interrupts (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) (,n-cache ,var-name)) (declare (type fixnum ,n-index)) ,@(sets) ,@(mapcar #'(lambda (i val) `(setf (svref ,n-cache ,i) ,val)) (values-indices) (values-names)) (values)))))) (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) (forms `(defun ,fun-name () (sys:without-interrupts (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size)) (,n-cache ,var-name)) ((minusp ,n-index)) (declare (type fixnum ,n-index)) ,@(collect ((arg-sets)) (dotimes (i nargs) (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) (arg-sets)) ,@(mapcar #'(lambda (i val) `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)) (values)))) (forms `(,fun-name))) (inits `(unless (boundp ',var-name) (setq ,var-name (make-array ,total-size)))) `(progn (defvar ,var-name) (,init-form ,@(inits)) (declaim (type (simple-vector ,total-size) ,var-name)) (declaim (inline ,@(inlines))) ,@(forms) ',name)))) ;;; DEFUN-CACHED -- Public ;;; (defmacro defun-cached ((name &rest options &key (values 1) default &allow-other-keys) args &parse-body (body decls doc)) "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* Some syntactic sugar for defining a function whose values are cached by DEFINE-HASH-CACHE." (let ((default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) (arg-names (mapcar #'car args)) (values-names (loop repeat values collect (gensym))) (cache-lookup (symbolicate name "-CACHE-LOOKUP")) (cache-enter (symbolicate name "-CACHE-ENTER"))) `(progn (define-hash-cache ,name ,args ,@options) (defun ,name ,arg-names ,@decls ,doc (multiple-value-bind ,values-names (,cache-lookup ,@arg-names) (if (and ,@(mapcar (lambda (val def) `(eq ,val ,def)) values-names default-values)) (multiple-value-bind ,values-names (progn ,@body) (,cache-enter ,@arg-names ,@values-names) (values ,@values-names)) (values ,@values-names))))))) ;;; CACHE-HASH-EQ -- Public ;;; (defmacro cache-hash-eq (x) "Return an EQ hash of X. The value of this hash for any given object can (of course) change at arbitary times." `(lisp::pointer-hash ,x)) cmucl-21a/src/code/extfmts.lisp000066400000000000000000001445501260377556400166560ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- ;;; ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; (ext:file-comment "$Header: src/code/extfmts.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Implementation of external-formats (in-package "STREAM") (intl:textdomain "cmucl") (export '(string-to-octets octets-to-string *default-external-format* string-encode string-decode set-system-external-format +replacement-character-code+ list-all-external-formats describe-external-format)) (defvar *default-external-format* :iso8859-1 "The default external format to use if no other external format is specified") (defvar *external-formats* (make-hash-table :test 'equal) "Hash table of all the external formats that have been loaded") (defvar *external-format-aliases* (make-hash-table) "Hash table mapping an external format alias to the actual external format implementation") ;; Each time DEF-EF-MACRO is used to define a new external format ;; macro, a unique value must be used for the index. The mapping ;; between the macro and the index is here. (vm::defenum (:prefix "+EF-" :suffix "+" :start 1) str ; string length cin ; input a character cout ; output a character sin ; input string sout ; output string os ; octets to string so ; string to octets en ; encode de ; decode flush ; flush state copy-state ; copy state osc ; octets to string, counted max) ;; Unicode replacement character U+FFFD (defconstant +replacement-character-code+ #xFFFD) (define-condition external-format-not-implemented (error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream (intl:gettext "Attempting unimplemented external-format I/O."))))) (define-condition external-format-not-found (error) ((name :reader external-format-not-found-name :initarg :name)) (:report (lambda (condition stream) (format stream (intl:gettext "External format ~S not found.") (external-format-not-found-name condition))))) (defun %efni (a b c d) (declare (ignore a b c d)) (error 'external-format-not-implemented)) (defstruct efx ;; ;; Function to read a sequence of octets from a stream and convert ;; them a code point. (octets-to-code #'%efni :type function :read-only t) ;; ;; Function to convert a codepoint to a sequence of octets and write ;; them to an output stream. (code-to-octets #'%efni :type function :read-only t) ;; ;; Function (or NIL) to force any state in the external format to be ;; flushed to the output stream. A NIL value means the external ;; format does not need to do anything special. (flush-state nil :type (or null function) :read-only t) ;; ;; Function to copy the state of the external-format. If NIL, then ;; there is no state to be copied. (copy-state nil :type (or null function) :read-only t) (cache nil :type (or null simple-vector)) ;; ;; Minimum number of octets needed to form a codepoint (min 1 :type kernel:index :read-only t) ;; ;; Maximum number of octets needed to form a codepoint. (max 1 :type kernel:index :read-only t) ;; ;; Documentation for this external format #+nil(documentation nil :type (or null string) :read-only t)) (defstruct (external-format (:conc-name ef-) (:print-function %print-external-format) (:constructor make-external-format (name efx composingp documentation &optional slots slotd))) (name (ext:required-argument) :type (or keyword cons) :read-only t) (efx (ext:required-argument) :type efx :read-only t) (composingp (ext:required-argument) :type boolean :read-only t) (slots #() :type simple-vector :read-only t) (slotd nil :type list :read-only t) (documentation nil :type (or null string) :read-only t)) (defun %print-external-format (ef stream depth) (declare (ignore depth)) (print-unreadable-object (ef stream :type t :identity t) (princ (ef-name ef) stream))) (defun %intern-ef (ef) (setf (gethash (ef-name ef) *external-formats*) ef)) (declaim (inline ef-octets-to-code ef-code-to-octets ef-flush-state ef-copy-state ef-cache ef-min-octets ef-max-octets)) (defun ef-octets-to-code (ef) (efx-octets-to-code (ef-efx ef))) (defun ef-code-to-octets (ef) (efx-code-to-octets (ef-efx ef))) (defun ef-flush-state (ef) (efx-flush-state (ef-efx ef))) (defun ef-copy-state (ef) (efx-copy-state (ef-efx ef))) (defun ef-cache (ef) (efx-cache (ef-efx ef))) (defun ef-min-octets (ef) (efx-min (ef-efx ef))) (defun ef-max-octets (ef) (efx-max (ef-efx ef))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun %merge-slots (old new) (let* ((pos (length old)) (tmp (mapcar (lambda (x) (let* ((name (if (consp x) (first x) x)) (init (if (consp x) (second x) nil)) (list (if (consp x) (nthcdr 2 x) nil)) (prev (assoc name old)) (posn (if prev (second prev) (1- (incf pos))))) (list name posn init (getf list :type t)))) new))) (delete-duplicates (stable-sort (append old tmp) #'< :key #'second) :key #'second)))) ;;; DEFINE-EXTERNAL-FORMAT -- Public ;;; ;;; name (&key base min max size documentation) (&rest slots) octets-to-code ;;; code-to-octets flush-state copy-state ;;; ;;; Define a new external format. If base is specified, then an ;;; external format is defined that is based on a previously defined ;;; external format named Base. The slot names used in Slots must ;;; match those defined in the Base format. ;;; ;;; If Base is not specified, a new external format is defined. ;;; Min/Max/Size are the minimum and maximum number of octets that ;;; make up a character (:size N is just shorthand for :min N :max ;;; N). Slots is a list of slot descriptions similar to defstruct. ;;; ;;; In both cases, Documentation is a string that documents the ;;; external format. ;;; ;;; octets-to-code (state input unput error &rest vars) ;;; Defines a form to be used by the external format to convert ;;; octets to a code point. State is a form that can be used by the ;;; body to access the state of the stream. Input is a form that ;;; can be used to read one octet from the input stream. (It can be ;;; called as many times as needed.) Similarly, Unput is a form to ;;; put back one octet to the input stream. Error is an error ;;; handler. The default is NIL to indicate that the code should do ;;; its default handling. Otherwise, it should be a function or ;;; symbol to indicate how errors are handled. Vars is a list of ;;; vars that need to be defined for any symbols used within the ;;; form. ;;; ;;; The error handler is a function of 3 arguments: a format message ;;; string, the offending octet (or NIL) and the number of octets ;;; read for this encoding. If the function returns, it should ;;; return the codepoint to be used in place of the erroneous ;;; sequence. ;;; ;;; This should return two values: the code and the number of octets ;;; read to form the code. ;;; ;;; code-to-octets (code state output error &rest vars) ;;; Defines a form to be used by the external format to convert a ;;; code point to octets for output. Code is the code point to be ;;; converted. State is a form to access the current value of the ;;; stream's state variable. Output is a form that writes one octet ;;; to the output stream. Error is the error handler. A value of ;;; NIL means the external format should use its default method. ;;; Otherwise, it should be a symbol or function that will e called ;;; to handle the error. ;;; ;;; The error function takes 2 arguments: a format message string ;;; and the offending codepoint. If the function returns, it should ;;; be the desired replacement codepoint. ;;; ;;; flush-state (state output error &rest vars) ;;; Defines a form to be used by the external format to flush out ;;; any state when an output stream is closed. Similar to ;;; CODE-TO-OCTETS, but there is no code. Error is similar to the ;;; error parameter for code-to-octets. ;;; ;;; copy-state (state &rest vars) ;;; Defines a form to copy any state needed by the external format. ;;; This should probably be a deep copy so that if the original ;;; state is modified, the copy is not. ;;; ;;; Note: external-formats work on code-points, not ;;; characters, so that the entire 31 bit ISO-10646 range can be ;;; used internally regardless of the size of a character recognized ;;; by Lisp and external formats can be useful to people who want to ;;; process characters outside the Lisp range (see ;;; CODEPOINT-TO-OCTETS, OCTETS-TO-CODEPOINT) ;;; (defmacro define-external-format (name (&key base min max size (documentation "")) (&rest slots) &optional octets-to-code code-to-octets flush-state copy-state) (let* ((tmp (gensym)) (min (or min size 1)) (max (or max size 6)) (base (when base (find-external-format base))) (bslotd (if base (ef-slotd base) nil)) (slotd (%merge-slots bslotd slots)) (slotb (loop for slot in slotd collect `(,(first slot) `(the ,',(fourth slot) ;; IDENTITY is here to protect against SETF (identity (svref %slots% ,',(second slot)))))))) (when documentation (intl::note-translatable intl::*default-domain* documentation)) `(macrolet ((octets-to-code ((state input unput error &rest vars) body) `(lambda (,state ,input ,unput ,error) (declare (ignorable ,state ,input ,unput ,error) (optimize (ext:inhibit-warnings 3))) (let (,@',slotb (,input `(the (or (unsigned-byte 8) null) ,,input)) ,@(loop for var in vars collect `(,var (gensym)))) ,body))) (code-to-octets ((code state output error &rest vars) body) `(lambda (,',tmp ,state ,output ,error) (declare (ignorable ,state ,output ,error) (optimize (ext:inhibit-warnings 3))) (let (,@',slotb (,code ',code) ,@(loop for var in vars collect `(,var (gensym)))) `(let ((,',code (the lisp:codepoint ,,',tmp))) (declare (ignorable ,',code)) ,,body)))) (flush-state ((state output error &rest vars) body) `(lambda (,state ,output ,error) (declare (ignorable ,state ,output ,error)) (let (,@',slotb ,@(loop for var in vars collect `(,var (gensym)))) ,body))) (copy-state ((state &rest vars) body) `(lambda (,state) (declare (ignorable ,state)) (let (,@',slotb ,@(loop for var in vars collect `(,var (gensym)))) ,body)))) (%intern-ef (make-external-format ,name ,(if base `(ef-efx (find-external-format ,(ef-name base))) `(make-efx :octets-to-code ,octets-to-code :code-to-octets ,code-to-octets :flush-state ,flush-state :copy-state ,copy-state :cache (make-array +ef-max+ :initial-element nil) :min ,(min min max) :max ,(max min max))) nil ,documentation (let* ,(loop for x in slotd collect (list (first x) (third x))) (vector ,@(mapcar #'first slotd))) ',slotd))))) ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT -- Public ;;; ;;; A composing-external-format differs from an (ordinary) external-format ;;; in that it translates characters (really codepoints, of course) into ;;; other characters, rather than translating between characters and binary ;;; octets. They have to be composed with a non-composing external-format ;;; to be of any use. ;;; ;;; ;;; name (&key min max size documentation) input output ;;; Defines a new composing external format. The parameters Min, ;;; Max, Size, and Documentation are the same as for defining an ;;; external format. The parameters input and output are forms to ;;; handle input and output. ;;; ;;; input (state input unput &rest vars) ;;; Defines a form to be used by the composing external format when ;;; reading input to transform a codepoint (or sequence of ;;; codepoints) to another. State is a form that can be used by the ;;; body to access the state of the external format. Input is a ;;; form that can be used to read one code point from the input ;;; stream. (Input returns two values, the codepoint and the number ;;; of octets read.) It may be called as many times as needed. ;;; This returns two values: the codepoint of the character (or NIL) ;;; and the number of octets read. Similarly, Unput is a form to ;;; put back one octet to the input stream. Vars is a list of vars ;;; that need to be defined for any symbols used within the form. ;;; ;;; This should return two values: the code and the number of octets ;;; read to form the code. ;;; ;;; output (code state output &rest vars) ;;; Defines a form to be used by the composing external format to ;;; convert a code point to octets for output. Code is the code ;;; point to be converted. State is a form to access the current ;;; value of the stream's state variable. Output is a form that ;;; writes one octet to the output stream. (defmacro define-composing-external-format (name (&key min max size documentation) input output) (let ((tmp (gensym)) (min (or min size 1)) (max (or max size 1))) `(macrolet ((input ((state input unput &rest vars) body) `(lambda (,state ,input ,unput) (declare (ignorable ,state ,input ,unput) (optimize (ext:inhibit-warnings 3))) (let ((,input `(the (values (or lisp:codepoint null) kernel:index) ,,input)) ,@(loop for var in vars collect `(,var (gensym)))) ,body))) (output ((code state output &rest vars) body) `(lambda (,',tmp ,state ,output) (declare (ignorable ,state ,output) (optimize (ext:inhibit-warnings 3))) (let ((,code ',code) ,@(loop for var in vars collect `(,var (gensym)))) `(let ((,',code (the lisp:codepoint ,,',tmp))) (declare (ignorable ,',code)) ,,body))))) (%intern-ef (make-external-format ,name (make-efx :octets-to-code ,input :code-to-octets ,output :min ,(min min max) :max ,(max min max)) t ,documentation #() '()))))) (defun load-external-format-aliases () (let ((*package* (find-package "KEYWORD")) (unix::*filename-encoding* :iso8859-1)) (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil :external-format :iso8859-1) (when stm (do ((alias (read stm nil stm) (read stm nil stm)) (value (read stm nil stm) (read stm nil stm))) ((or (eq alias stm) (eq value stm)) (unless (eq alias stm) (warn (intl:gettext "External-format aliases file ends early.")))) (if (and (keywordp alias) (or (keywordp value) (and (consp value) (every #'keywordp value)))) (setf (gethash alias *external-format-aliases*) value) (warn (intl:gettext "Bad entry in external-format aliases file: ~S => ~S.") alias value))))))) (defun list-all-external-formats () "List the available external formats. A list is returned where each element is list of the external format and a list of aliases for the format. No distinction is made between external formats and composing external formats." ;; Look for all lisp files in the ext-formats directory. These are ;; the available formats. (let ((ef (make-hash-table)) result) (map nil #'(lambda (p) (setf (gethash (intern (string-upcase (pathname-name p)) :keyword) ef) nil)) (directory "ext-formats:*.lisp")) ;; Look through aliases and update formats with a list of aliases. (load-external-format-aliases) (maphash #'(lambda (k v) (push k (gethash v ef))) *external-format-aliases*) (maphash #'(lambda (k v) (push (if v (list k v) (list k)) result)) ef) (sort result #'string< :key #'first))) (defun describe-external-format (external-format) "Print a description of the given External-Format. This may cause the external format to be loaded (silently), if it is not already loaded." (when (zerop (hash-table-count *external-format-aliases*)) (load-external-format-aliases)) (let ((alias (gethash external-format *external-format-aliases*))) (cond (alias (format t (intl:gettext "~&~S is an alias for the external format ~S.~2%") external-format alias)) ((and (listp external-format) (> (length external-format) 1)) ;; Some kind of composed external format (format t (intl:gettext "~&~S is a composed external format.~2%") external-format)) (t (let ((ef (handler-case (let ((*compile-print* nil) (ext:*compile-progress* nil) (*compile-verbose* nil)) ;; Should we be this silent when ;; loading the external format? ;; We aren't when the normally ;; loading the format. (find-external-format external-format)) (external-format-not-found () (format *error-output* (intl:gettext "~&Could not find external format ~S~%") external-format))))) (when ef (let (aliases) ;; Find any aliases for this external format. Doesn't need to be efficient. (maphash #'(lambda (k v) (when (eq v external-format) (push k aliases))) *external-format-aliases*) (format t (intl:gettext "~S~:[~; - [Aliases: ~{~S~^, ~}~]]~%") external-format aliases aliases)) (when (ef-composingp ef) (format t (intl:gettext "~&~S is a composing external format.~2%") external-format)) (format t "~&~A~%" (intl:gettext (or (ef-documentation ef) ""))))))))) (defun %find-external-format (name) ;; avoid loading files, etc., early in the boot sequence (when (or (eq name :iso8859-1) (and (eq name :default) (eq *default-external-format* :iso8859-1))) (return-from %find-external-format (gethash :iso8859-1 *external-formats*))) (when (eq name :utf-8) (return-from %find-external-format (gethash :utf-8 *external-formats*))) (when (zerop (hash-table-count *external-format-aliases*)) (setf (gethash :latin1 *external-format-aliases*) :iso8859-1) (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1) (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1) (load-external-format-aliases)) (do ((tmp (gethash name *external-format-aliases*) (gethash tmp *external-format-aliases*)) (cnt 0 (1+ cnt))) ((or (null tmp) (= cnt 50)) (unless (null tmp) (error (intl:gettext "External-format aliasing depth exceeded.")))) (setq name tmp)) (or (gethash name *external-formats*) (and (consp name) (find-external-format name)) (and (with-standard-io-syntax ;; Use standard IO syntax so that changes by the user ;; don't mess up compiling the external format. (let ((*package* (find-package "STREAM")) (lisp::*enable-package-locked-errors* nil) (s (open (format nil "ext-formats:~(~A~).lisp" name) :if-does-not-exist nil :external-format :iso8859-1))) (when s (null (nth-value 1 (ext:compile-from-stream s)))))) (gethash name *external-formats*)))) (defun %composed-ef-name (a b) (if (consp a) (append a (list b)) (list a b))) (defun %compose-external-formats (a b) (when (ef-composingp a) (error (intl:gettext "~S is a Composing-External-Format.") (ef-name a))) (unless (ef-composingp b) (error (intl:gettext "~S is not a Composing-External-Format.") (ef-name b))) (make-external-format (%composed-ef-name (ef-name a) (ef-name b)) (make-efx :octets-to-code (lambda (state input unput error) (let ((nstate (gensym "STATE-"))) `(let ((,nstate ,state)) (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) ,(funcall (ef-octets-to-code b) `(car ,nstate) (funcall (ef-octets-to-code a) `(cdr ,nstate) input unput error) unput)))) :code-to-octets (lambda (code state output error) (let ((nstate (gensym "STATE-"))) `(let ((,nstate ,state)) (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) ,(funcall (ef-code-to-octets b) code `(car ,nstate) `(lambda (x) ,(funcall (ef-code-to-octets a) 'x `(cdr ,nstate) output error)))))) :cache (make-array +ef-max+ :initial-element nil) :min (* (ef-min-octets a) (ef-min-octets b)) :max (* (ef-max-octets a) (ef-max-octets b))) nil nil #() '())) (defun find-external-format (name &optional (error-p t)) (when (external-format-p name) (return-from find-external-format name)) (or (if (consp name) (every #'keywordp name) (keywordp name)) (error (intl:gettext "~S is not a valid external format name.") name)) (when (eq name :default) (setq name *default-external-format*)) (when (and (consp name) (not (cdr name))) (setq name (car name))) (flet ((not-found () (when (equal *default-external-format* name) (setq *default-external-format* :iso8859-1)) (if error-p (error 'external-format-not-found :name name) nil))) (if (consp name) (let ((efs (mapcar #'%find-external-format name))) (if (member nil efs) (not-found) (let ((name (reduce #'%composed-ef-name (mapcar #'ef-name efs)))) (or (gethash name *external-formats*) (%intern-ef (reduce #'%compose-external-formats efs)))))) (or (%find-external-format name) (not-found))))) (defun flush-external-formats () (maphash (lambda (name ef) (declare (ignore name)) (fill (ef-cache ef) nil)) *external-formats*)) (defvar *.table-inverse.* (make-hash-table :test 'eq :size 7)) ;; Create a trie that is the inverse of the given table. The table ;; can be an array of rank 1 or 2. Each dimension is limited to a ;; maximum of 254. ;; ;; Let table have rank 1 and let (aref table k) = uuuu. Then ;; INVERT-TABLE creates a trie such that (get-inverse (invert-table ;; table) uuuu) = #xbb and (aref table (1- #xbb)) = uuuu. If, ;; however, the table has no entry that matches uuuu, get-inverse ;; returns NIL. ;; ;; For a table of rank 2, we have (aref table m n) = uuuu, Then ;; INVERT-TABLE creates a trie such that (get-inverse (invert-table ;; table) uuuu) = #xaabb, where (aref table (1- #xbb) (1- #xaa)) = ;; uuuu. (defun invert-table (table) (declare (type (or (simple-array (unsigned-byte 31) *) (simple-array (unsigned-byte 16) *)) table) (optimize (speed 3) (space 0) (safety 0) (debug 0) (ext:inhibit-warnings 3))) (or (gethash table *.table-inverse.*) (let* ((mbits (if (= (array-total-size table) 128) 7 8)) (lbits (cond ((> (array-total-size table) 256) 3) ((< (array-total-size table) 100) 6) (t 5))) (hvec (make-array (1+ (ash #x110000 (- 0 mbits lbits))) :element-type '(unsigned-byte 16) :initial-element #xFFFF)) (mvec (make-array 0 :element-type '(unsigned-byte 16))) (lvec (make-array 0 :element-type '(unsigned-byte 16))) (width (array-dimension table 0)) (power (1- (array-rank table))) (base (if (= width 94) 1 0)) hx mx lx) (assert (and (< power 2) (<= width 16384))) (dotimes (i (array-total-size table)) (declare (type (integer 0 (#.array-dimension-limit)) i)) (let ((tmp i) (val (row-major-aref table i)) (z 0)) (declare (type (integer 0 (#.array-dimension-limit)) tmp) (type (unsigned-byte 16) z)) (unless (= val #xFFFE) (when (plusp power) (multiple-value-bind (x y) (floor tmp width) (setq tmp x) (setq z (logior z (ash (the (integer 0 255) (+ y base)) (the (integer 0 24) (* 8 power))))))) (setq hx (ash val (- 0 mbits lbits))) (when (= (aref hvec hx) #xFFFF) (setf (aref hvec hx) (length mvec)) (let ((tmp (make-array (+ (length mvec) (ash 1 mbits)) :element-type '(unsigned-byte 16) :initial-element #xFFFF))) (replace tmp mvec) (setq mvec tmp))) (setq mx (logand (ash val (- lbits)) (lognot (ash -1 mbits)))) (when (= (aref mvec (+ (aref hvec hx) mx)) #xFFFF) (setf (aref mvec (+ (aref hvec hx) mx)) (length lvec)) (let ((tmp (make-array (+ (length lvec) (ash 1 lbits)) :element-type '(unsigned-byte 16) :initial-element #xFFFF))) (replace tmp lvec) (setq lvec tmp))) (setq lx (logand val (lognot (ash -1 lbits)))) (setf (aref lvec (+ (aref mvec (+ (aref hvec hx) mx)) lx)) (logior z (+ tmp base)))))) (setf (gethash table *.table-inverse.*) (lisp::make-ntrie16 :split (logior (ash (1- mbits) 4) (1- lbits)) :hvec hvec :mvec mvec :lvec lvec))))) (declaim (inline get-inverse)) (defun get-inverse (ntrie code) (declare (type lisp::ntrie16 ntrie) (type (integer 0 #x10FFFF) code)) (let ((n (lisp::qref ntrie code))) (and n (let ((m (aref (lisp::ntrie16-lvec ntrie) n))) (if (= m #xFFFF) nil m))))) (define-condition void-external-format (error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream (intl:gettext "Attempting I/O through void external-format."))))) (define-external-format :void (:size 0 :documentation "Void external format that signals an error on any input or output.") () (octets-to-code (state input unput error) `(error 'void-external-format)) (code-to-octets (code state output error) `(error 'void-external-format))) (define-external-format :iso8859-1 (:size 1 :documentation "ISO8859-1 is an 8-bit character encoding generally intended for Western European languages including English, German, Italian, Norwegian, Portuguese, Spanish, Swedish and many others. By default, illegal inputs are replaced by the Unicode replacement character and illegal outputs are replaced by a question mark.") () (octets-to-code (state input unput error) `(values ,input 1)) (code-to-octets (code state output error) `(,output (if (> ,code 255) (if ,error (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream") ,code 1)) #x3F) ,code)))) ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS -- Semi-Public ;;; ;;; Normally you'd want to use OCTETS-TO-CHAR and CHAR-TO-OCTETS instead of ;;; these, but that limits you to Lisp's idea of a character - either Latin-1 ;;; in 8 bit Lisp images, or the Unicode BMP in 16 bit images. If you want ;;; to read or write texts containing characters not supported by your Lisp, ;;; these macros can be used instead. (defmacro octets-to-codepoint (external-format state count input unput &optional error) (let ((tmp1 (gensym)) (tmp2 (gensym)) (ef (find-external-format external-format))) `(multiple-value-bind (,tmp1 ,tmp2) ,(funcall (ef-octets-to-code ef) state input unput error) (setf ,count (the kernel:index ,tmp2)) (the (or lisp:codepoint null) ,tmp1)))) (defmacro codepoint-to-octets (external-format code state output &optional error) (let ((ef (find-external-format external-format))) (funcall (ef-code-to-octets ef) code state output error))) (defvar *ef-base* +ef-max+) (defvar *ef-extensions* '()) (defun ensure-cache (ef id reqd) (let ((base (or (getf *ef-extensions* id) (setf (getf *ef-extensions* id) (prog1 *ef-base* (incf *ef-base* reqd)))))) (when (< (length (ef-cache ef)) (+ base reqd)) (setf (efx-cache (ef-efx ef)) (adjust-array (ef-cache ef) (+ base reqd) :initial-element nil))) base)) ;;; DEF-EF-MACRO -- Public ;;; ;;; Create an ef-macro (external-format macro). This creates a ;;; function named Name that will process an external format in the ;;; desired way. ;;; ;;; Paul Foley says: ;;; All the existing ef-macros are provided with the implementation, ;;; so they all use lisp::lisp as the id; it's intended for people ;;; who want to write their own macros~there are some number of ;;; slots (+ef-max+) used by the implementation; the idea is that ;;; you can write something like (def-ef-macro foo (ef my-tag 4 1) ;;; ...) to implement 1 of a total of 4 new macros in your own ;;; "namespace", without having to know how many are implemented by ;;; others (e.g., the 10 used by the base implementation...which ;;; could change with the next release -- and if several libraries ;;; each add their own, the total number, and the position of each ;;; one's slots within that total, may change depending on load ;;; order, etc.) When you write the above, it allocates 4 new ;;; places and associates the base index with "my-tag", then the ;;; "idx" value is relative to that base. The id lisp:lisp always ;;; has its base at 0, so it doesn't need to go through ensure-cache ;;; to find that out. (defmacro def-ef-macro (name (ef id reqd idx) body) (let* ((tmp1 (gensym)) (tmp2 (gensym)) (blknm (nth-value 1 (lisp::valid-function-name-p name))) (%name (intern (format nil "%~A" name) #|(symbol-package blknm)|#))) `(progn (defun ,%name (,ef) (let* ((,tmp1 (find-external-format ,ef)) (,tmp2 ,(if (eq id 'lisp::lisp) idx `(+ (ensure-cache ,tmp1 ',id ,reqd) ,idx)))) (funcall (or (aref (ef-cache ,tmp1) ,tmp2) (setf (aref (ef-cache ,tmp1) ,tmp2) (let ((*compile-print* nil) ;; Set default format when we compile so we ;; can see compiler messages. If we don't, ;; we run into a problem that we might be ;; changing the default format while we're ;; compiling, and we don't know how to output ;; the compiler messages. #|(*default-external-format* :iso8859-1)|#) (compile nil `(lambda (%slots%) (declare (ignorable %slots%)) (block ,',blknm ,,body)))))) (ef-slots ,tmp1)))) (declaim (inline ,name)) (defun ,name (,tmp1) (let ((,tmp2 (load-time-value (cons nil nil)))) (when (eq ,tmp1 :default) (setq ,tmp1 *default-external-format*)) (if (eq ,tmp1 (car ,tmp2)) (cdr ,tmp2) (setf (car ,tmp2) ,tmp1 (cdr ,tmp2) (,%name ,tmp1)))))))) ;;; OCTETS-TO-CHAR, CHAR-TO-OCTETS -- Public ;;; ;;; Read and write one character through an external-format ;;; (defmacro octets-to-char (external-format state count input unput &optional error) (let ((nstate (gensym))) `(let ((,nstate ,state)) (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) (if (car ,nstate) ;; Return the trailing surrgate. Must set count to 0 to ;; tell the stream code we didn't consume any octets! (prog1 (the character (car ,nstate)) (setf (car ,nstate) nil ,count 0)) (let ((code (octets-to-codepoint ,external-format (cdr ,nstate) ,count ,input ,unput ,error))) (declare (type lisp:codepoint code)) ;;@@ on non-Unicode builds, limit to 8-bit chars ;;@@ if unicode-bootstrap, can't use #\u+fffd (cond ((or (lisp::surrogatep code) (>= code lisp:codepoint-limit)) ;; Surrogate characters (that weren't combined ;; into a codepoint by octets-to-codepoint) are ;; illegal. So are codepoints that are too large. (if ,error (if (lisp::surrogatep code) (locally (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error (format nil (intl:gettext "Surrogate codepoint #x~~4,'0X is illegal for ~A") ,external-format) code nil)) (locally (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error (intl:gettext "Illegal codepoint on input: #x~X") code nil))) #-(and unicode (not unicode-bootstrap)) #\? #+(and unicode (not unicode-bootstrap)) #\U+FFFD)) #+unicode ((> code #xFFFF) (multiple-value-bind (hi lo) (surrogates code) (setf (car ,nstate) lo) hi)) (t (code-char code)))))))) (defmacro char-to-octets (external-format char state output &optional error) (let ((nchar (gensym)) (nstate (gensym)) (wryte (gensym)) (ch (gensym))) `(let ((,nchar ,char) (,nstate ,state)) (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) (if (lisp::surrogatep (char-code ,nchar) :high) (setf (car ,nstate) ,nchar) (flet ((,wryte (,ch) (codepoint-to-octets ,external-format ,ch (cdr ,nstate) ,output ,error))) (declare (dynamic-extent #',wryte)) (if (car ,nstate) (prog1 ;; Invalid surrogate sequences get replaced with ;; the replacement character. (,wryte (if (lisp::surrogatep (char-code ,nchar) :low) (surrogates-to-codepoint (car ,nstate) ,nchar) (if ,error (locally (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error (intl:gettext "Cannot convert invalid surrogate #x~X to character") ,nchar)) +replacement-character-code+))) (setf (car ,nstate) nil)) ;; A lone trailing (low) surrogate gets replaced with ;; the replacement character. (,wryte (if (lisp::surrogatep (char-code ,nchar) :low) (if ,error (locally (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error (intl:gettext "Cannot convert lone trailing surrogate #x~X to character") ,nchar)) +replacement-character-code+) (char-code ,nchar))))))))) (defmacro flush-state (external-format state output &optional error) (let* ((ef (find-external-format external-format)) (f (ef-flush-state ef))) (when f (funcall f state output error)))) (defmacro copy-state (external-format state) (let* ((ef (find-external-format external-format)) (f (ef-copy-state ef))) (when f (funcall f state)))) (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+) `(lambda (string start end buffer buffer-start buffer-end error bufferp &aux (ptr buffer-start) (state nil) (last-octet buffer-start)) (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|# (type simple-string string) (type kernel:index start end ptr) (type (simple-array (unsigned-byte 8) (*)) buffer) (ignorable state)) (if bufferp (block ef-string-done (dotimes (i (- end start) (values buffer ptr i)) (declare (type kernel:index i)) (char-to-octets ,extfmt (schar string (+ start i)) state (lambda (b) (when (= ptr buffer-end) (return-from ef-string-done (values buffer last-octet i))) (setf (aref buffer (1- (incf ptr))) b)) error) (setf last-octet ptr))) (dotimes (i (- end start) (values buffer ptr i)) (declare (type kernel:index i)) (char-to-octets ,extfmt (schar string (+ start i)) state (lambda (b) (when (= ptr (length buffer)) (setq buffer (adjust-array buffer (* 2 ptr)))) (setf (aref buffer (1- (incf ptr))) b)) error))))) (defun string-to-octets (string &key (start 0) end (external-format :default) (buffer nil bufferp) (buffer-start 0) error) "Convert String to octets using the specified External-format. The string is bounded by Start (defaulting to 0) and End (defaulting to the end of the string. If Buffer is given, the octets are stored there. If not, a new buffer is created. Buffer-start specifies where in the buffer the first octet will be placed. Three values are returned: The buffer, the number of valid octets written, and the number of characters converted. Note that the actual number of octets written may be greater than the returned value, These represent the partial octets of the next character to be converted, but there was not enough room to hold the complete set of octets." (declare (type string string) (type kernel:index start) (type (or kernel:index null) end) (type (or (array (unsigned-byte 8) (*)) null) buffer)) (let* ((buffer (or buffer (make-array (length string) :element-type '(unsigned-byte 8))))) (lisp::with-array-data ((b buffer) (b-start) (b-end)) (multiple-value-bind (result ptr octets) (lisp::with-array-data ((string string) (start start) (end end)) (funcall (ef-string-to-octets external-format) string start end b (+ b-start buffer-start) b-end error bufferp)) (values (if bufferp buffer (lisp::shrink-vector result ptr)) (- ptr b-start buffer-start) octets))))) (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+) `(lambda (octets ptr end state string s-start s-end error &aux (pos s-start) (count 0) (last-octet 0)) (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#) (type (simple-array (unsigned-byte 8) (*)) octets) (type kernel:index pos end count last-octet s-start s-end) (type (integer -1 (#.array-dimension-limit)) ptr) (type simple-string string) (ignorable state)) (catch 'end-of-octets (loop while (< pos s-end) do (setf (schar string pos) (octets-to-char ,extfmt state count (if (>= ptr end) (throw 'end-of-octets nil) (aref octets (incf ptr))) (lambda (n) (decf ptr n)) error)) (incf pos) (incf last-octet count))) (values string pos last-octet state))) (defun octets-to-string (octets &key (start 0) end (external-format :default) (string nil stringp) (s-start 0) (s-end nil s-end-p) (state nil) error) "Octets-to-string converts an array of octets in Octets to a string according to the specified External-format. The array of octets is bounded by Start (defaulting ot 0) and End (defaulting to the end of the array. If String is not given, a new string is created. If String is given, the converted octets are stored in String, starting at S-Start (defaulting to the 0) and ending at S-End (defaulting to the length of String). If the string is not large enough to hold all of characters, then some octets will not be converted. A State may also be specified; this is used as the state of the external format. An error method may also be specified by Error, which defaults to NIL to mean the default handling of conversion errors is done. Four values are returned: the string, the position of where the next character would be read into the string, the number of octets actually consumed and the new state of the external format." (declare (type (simple-array (unsigned-byte 8) (*)) octets) (type kernel:index start s-start) (type (or kernel:index null) end) (type (or simple-string null) string)) (let ((s-end (if s-end-p s-end (if stringp (length string) (length octets))))) (multiple-value-bind (string pos last-octet new-state) (funcall (ef-octets-to-string external-format) octets (1- start) (1- (or end (length octets))) state (or string (make-string (length octets))) s-start s-end error) (values (if stringp string (lisp::shrink-vector string pos)) pos last-octet new-state)))) (def-ef-macro ef-octets-to-string-counted (extfmt lisp::lisp +ef-max+ +ef-osc+) `(lambda (octets ptr end state ocount string s-start s-end error &aux (pos s-start) (last-octet 0)) (declare (optimize (speed 3) (safety 0) #|(space 0) (debug 0)|#) (type (simple-array (unsigned-byte 8) (*)) octets ocount) (type kernel:index pos end last-octet s-start s-end) (type (integer -1 (#.array-dimension-limit)) ptr) (type simple-string string) (ignorable state)) (catch 'end-of-octets (loop for k of-type fixnum from 0 while (< pos s-end) do (setf (schar string pos) (octets-to-char ,extfmt state (aref ocount k) (if (>= ptr end) (throw 'end-of-octets nil) (aref octets (incf ptr))) (lambda (n) (decf ptr n)) error)) (incf pos) (incf last-octet (aref ocount k)))) (values string pos last-octet state))) ;; Like OCTETS-TO-STRING, but we take an extra argument which is an ;; array which will contain the number of octets read for each ;; character placed in the output string. (defun octets-to-string-counted (octets ocount &key (start 0) end (external-format :default) (string nil stringp) (s-start 0) (s-end nil s-end-p) (state nil) error) "Octets-to-string converts an array of octets in Octets to a string according to the specified External-format. The array of octets is bounded by Start (defaulting ot 0) and End (defaulting to the end of the array. If String is not given, a new string is created. If String is given, the converted octets are stored in String, starting at S-Start (defaulting to the 0) and ending at S-End (defaulting to the length of String). If the string is not large enough to hold all of characters, then some octets will not be converted. A State may also be specified; this is used as the state of the external format. In Ocount, the number of octets read for each character in the string is saved Four values are returned: the string, the number of characters read, the number of octets actually consumed and the new state of the external format." (declare (type (simple-array (unsigned-byte 8) (*)) octets ocount) (type kernel:index start s-start) (type (or kernel:index null) end) (type (or simple-string null) string)) (let ((s-end (if s-end-p s-end (if stringp (length string) (length octets))))) (multiple-value-bind (string pos last-octet new-state) (funcall (ef-octets-to-string-counted external-format) octets (1- start) (1- (or end (length octets))) state ocount (or string (make-string (length octets))) s-start s-end error) (values (if stringp string (lisp::shrink-vector string pos)) (- pos s-start) last-octet new-state)))) (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+) `(lambda (string start end result error &aux (ptr 0) (state nil)) (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|# (type simple-string string) (type kernel:index start end ptr) (type simple-base-string result) (ignorable state)) (dotimes (i (- end start) (values result ptr)) (declare (type kernel:index i)) (char-to-octets ,extfmt (schar string (+ start i)) state (lambda (b) (when (= ptr (length result)) (setq result (adjust-array result (* 2 ptr)))) (setf (aref result (1- (incf ptr))) (code-char b))) error)))) (defun string-encode (string external-format &optional (start 0) end error) "Encode the given String using External-Format and return a new string. The characters of the new string are the octets of the encoded result, with each octet converted to a character via code-char. This is the inverse to String-Decode" (when (zerop (length string)) (return-from string-encode string)) (multiple-value-bind (result ptr) (lisp::with-array-data ((string string) (start start) (end end)) (funcall (ef-encode external-format) string start end (make-string (length string) :element-type 'base-char) error)) (lisp::shrink-vector result ptr))) (def-ef-macro ef-decode (extfmt lisp::lisp +ef-max+ +ef-de+) `(lambda (string ptr end result error &aux (pos -1) (count 0) (state nil)) (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|# (type simple-string string) (type kernel:index end count) (type (integer -1 (#.array-dimension-limit)) ptr pos) (type simple-string result) (ignorable state)) (loop until (>= ptr end) ;; increasing size of result shouldn't ever be necessary, unless ;; someone implements an encoding smaller than the source string... do (setf (schar result (incf pos)) (octets-to-char ,extfmt state count ;; note the need to return NIL for EOF (if (= (1+ ptr) (length string)) nil (char-code (char string (incf ptr)))) (lambda (n) (decf ptr n)) error)) finally (return (values result (1+ pos)))))) (defun string-decode (string external-format &optional (start 0) end error) "Decode String using the given External-Format and return the new string. The input string is treated as if it were an array of octets, where the char-code of each character is the octet. This is the inverse of String-Encode." (when (zerop (length string)) (return-from string-decode string)) (multiple-value-bind (result pos) (lisp::with-array-data ((string string) (start start) (end end)) (funcall (ef-decode external-format) string (1- start) (1- end) (make-string (length string)) error)) (lisp::shrink-vector result pos))) (defun set-system-external-format (terminal &optional filenames) "Change the external format of the standard streams to Terminal. The standard streams are sys::*stdin*, sys::*stdout*, and sys::*stderr*, which are normally the input and/or output streams for *standard-input* and *standard-output*. Also sets sys::*tty* (normally *terminal-io* to the given external format. If the optional argument Filenames is gvien, then the filename encoding is set to the specified format." (unless (find-external-format terminal) (error (intl:gettext "Can't find external-format ~S.") terminal)) (setf (stream-external-format sys:*stdin*) terminal (stream-external-format sys:*stdout*) terminal (stream-external-format sys:*stderr*) terminal) (when (lisp::fd-stream-p sys:*tty*) (setf (stream-external-format sys:*tty*) terminal)) (when filenames (unless (find-external-format filenames) (error (intl:gettext "Can't find external-format ~S.") filenames)) (setq filenames (ef-name (find-external-format filenames))) (when (and unix::*filename-encoding* (not (eq unix::*filename-encoding* filenames))) (cerror (intl:gettext "Change it anyway.") (intl:gettext "The external-format for encoding filenames is already set."))) (setq unix::*filename-encoding* filenames)) t) ;; Despite its name, this doesn't actually compile anything at all. What it ;; does is expand into a lambda expression that can be compiled by the file ;; compiler. (defmacro precompile-ef-slot (ef slot) (let* ((ef (find-external-format ef))) ;; if there's no lambda expression available, flush it and regenerate (unless (and (aref (ef-cache ef) slot) (function-lambda-expression (aref (ef-cache ef) slot))) (setf (aref (ef-cache ef) slot) nil) (ecase slot (#.+ef-cin+ (lisp::%ef-cin ef)) (#.+ef-cout+ (lisp::%ef-cout ef)) (#.+ef-sout+ (lisp::%ef-sout ef)) (#.+ef-os+ (%ef-octets-to-string ef)) (#.+ef-so+ (%ef-string-to-octets ef)) (#.+ef-en+ (%ef-encode ef)) (#.+ef-de+ (%ef-decode ef)) (#.+ef-osc+ (%ef-octets-to-string-counted ef)))) `(setf (aref (ef-cache (find-external-format ,(ef-name ef))) ,slot) ,(subst (ef-name ef) ef (function-lambda-expression (aref (ef-cache ef) slot)))))) ;; A safe UTF-8 external format. Any illegal UTF-8 sequences on input ;; are replaced with the Unicode REPLACEMENT CHARACTER (U+FFFD), or ;; signals an error as appropriate. ;; ;; See Table 3-7, Ch 3.9 in the Unicode book. (define-external-format :utf-8 (:min 1 :max 4 :documentation "UTF-8 is a variable-length character encoding for Unicode. By default, illegal input sequences are replaced by the Unicode replacement character.") () (octets-to-code (state input unput error c i j n) `(labels ((utf8 (,c ,i) (declare (type (unsigned-byte 8) ,c) (type (integer 1 5) ,i)) (let ((,n (ash (ldb (byte (- 6 ,i) 0) ,c) (* 6 ,i)))) (declare (type (unsigned-byte 31) ,n)) (dotimes (,j ,i (check ,n ,i)) (let ((,c ,input)) ;; Following bytes must all have the form ;; #b10xxxxxx. If not, put back the octet we ;; just read and return the replacement character ;; for the bad sequence. (if (< (logxor ,c #x80) #x40) (setf (ldb (byte 6 (* 6 (- ,i ,j 1))) ,n) (ldb (byte 6 0) ,c)) (progn (,unput 1) (return (values (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (if ,error (funcall ,error "Invalid utf8 octet #x~X at offset ~D" ,c (1+ ,j)) +replacement-character-code+)) (1+ ,j))))))))) (check (,n ,i) (declare (type (unsigned-byte 31) ,n) (type (integer 1 5) ,i)) ;; We check for overlong sequences (sequences that ;; encode to codepoints that don't need that long of a ;; sequence) and any surrogate values and any code ;; outside the 21-bit Unicode range. (if (or (>= ,n lisp:codepoint-limit) (<= ,n (the (member 127 2047 65535) (svref #(127 2047 65535) (1- ,i)))) ; overlong (lisp::surrogatep ,n)) ; surrogate (progn ;; Replace the entire sequence with the ;; replacment character (values (if ,error (cond ((>= ,n lisp:codepoint-limit) (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Invalid codepoint #x~X of ~D octets" ,n (1+ ,i)))) ((lisp::surrogatep ,n) (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Invalid surrogate code #x~X" ,n (1+ ,i)))) (t (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Overlong utf8 sequence of ~*~D octets" nil (1+ ,i))))) +replacement-character-code+) (1+ ,i))) (values ,n (1+ ,i))))) (let ((,c ,input)) (declare (optimize (ext:inhibit-warnings 3))) (cond ((null ,c) (values nil 0)) ((< ,c #b10000000) (values ,c 1)) ((< ,c #b11000010) (values (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (if ,error (funcall ,error "Invalid initial utf8 octet: #x~X" ,c 1) +replacement-character-code+)) 1)) ((< ,c #b11100000) (utf8 ,c 1)) ((< ,c #b11110000) (utf8 ,c 2)) ((< ,c #b11111000) (utf8 ,c 3)) (t (values (locally ;; No warnings about fdefinition (declare (optimize (ext:inhibit-warnings 3))) (if ,error (funcall ,error "Invalid initial utf8 octet: #x~X" ,c 1) +replacement-character-code+)) 1)))))) (code-to-octets (code state output error i j n p init) `(flet ((utf8 (,n ,i) (let* ((,j (- 6 ,i)) (,p (* 6 ,i)) (,init (logand #xFF (ash #b01111110 ,j)))) (,output (logior ,init (ldb (byte ,j ,p) ,n))) (dotimes (,i ,i) (decf ,p 6) (,output (logior 128 (ldb (byte 6 ,p) ,n))))))) (declare (optimize (ext:inhibit-warnings 3))) (cond ((< ,code #x80) (,output ,code)) ((< ,code #x800) (utf8 ,code 1)) ((< ,code #x10000) (utf8 ,code 2)) ((< ,code #x110000) (utf8 ,code 3)) (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) cmucl-21a/src/code/fd-stream-comp.lisp000066400000000000000000000030721260377556400177730ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: LISP -*- ;;; ;;; ********************************************************************** ;;; This has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/fd-stream-comp.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Precompile builtin external-formats. (in-package "LISP") (intl:textdomain "cmucl") ;; The external format :iso8859-1 is builtin so we want all of the ;; basic methods to be compiled so that they don't have to be compiled ;; at runtime. There are issues if we don't do this. ;; ;; These are needed for both unicode and non-unicode Lisps. (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cin+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cout+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-sout+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-os+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-so+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-en+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-de+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-osc+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-cin+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-cout+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-sout+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-os+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-so+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-en+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-de+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-osc+) cmucl-21a/src/code/fd-stream-extfmt.lisp000066400000000000000000000170431260377556400203470ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: LISP -*- ;;; ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. ;;; (ext:file-comment "$Header: src/code/fd-stream-extfmt.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Implementation of external-formats for fd-streams (in-package "LISP") (intl:textdomain "cmucl") ;; an fd-sout that works with external-formats; needs slots in fd-stream (defun fd-sout (stream thing start end) (let ((start (or start 0)) (end (or end (length (the vector thing))))) (declare (type index start end)) (if (stringp thing) (let ((last-newline (and (find #\newline (the simple-string thing) :start start :end end) (position #\newline (the simple-string thing) :from-end t :start start :end end)))) (funcall (ef-sout (fd-stream-external-format stream)) stream thing start end) (ecase (fd-stream-buffering stream) (:full #| do nothing |#) (:line (when last-newline (flush-output-buffer stream))) (:none (flush-output-buffer stream))) (if last-newline (setf (fd-stream-char-pos stream) (- end last-newline 1)) (incf (fd-stream-char-pos stream) (- end start)))) (ecase (fd-stream-buffering stream) ((:line :full) (output-raw-bytes stream thing start end)) (:none (do-output stream thing start end nil)))))) (defun (setf stream-external-format) (extfmt stream) (declare (type stream stream)) (stream-dispatch stream ;; simple-stream (error (intl:gettext "Loading simple-streams should redefine this")) ;; lisp-stream (typecase stream (fd-stream (%set-fd-stream-external-format stream extfmt)) (synonym-stream (setf (stream-external-format (symbol-value (synonym-stream-symbol stream))) extfmt)) (t (error (intl:gettext "Don't know how to set external-format for ~S.") stream))) ;; fundamental-stream (error (intl:gettext "Setting external-format on Gray streams not supported."))) extfmt) (defun %set-fd-stream-external-format (stream extfmt &optional (updatep t)) (declare (type fd-stream stream)) (let ((old-format (fd-stream-external-format stream))) (setf (fd-stream-external-format stream) (stream::ef-name (stream::find-external-format extfmt)) (fd-stream-oc-state stream) nil (fd-stream-co-state stream) nil) ;; Set fd-stream-in only if we have an input stream for a ;; character stream or binary-text-stream. (when (and (fd-stream-ibuf-sap stream) (plusp (logand #b101 (lisp-stream-flags stream)))) (setf (fd-stream-in stream) (ef-cin extfmt))) ;; Set fd-stream-in only if we have an input stream for a ;; character stream or binary-text-stream. (when (and (fd-stream-obuf-sap stream) (plusp (logand #b101 (lisp-stream-flags stream)))) (setf (fd-stream-out stream) (ef-cout extfmt) ;;@@ (fd-stream-sout stream) (ef-sout extfmt) )) ;; The following handles the case of setting the external format ;; for input streams where we need to handle the various buffering ;; strategies. But don't change anything if we have a ;; binary-text-stream. In that case, we don't want to set the ;; lisp-stream-in-buffer or lisp-stream-string-buffer which would ;; cause the FAST-READ-CHAR/FAST-READ-BYTE functions to bypass the ;; methods. (unless (typep stream 'binary-text-stream) (cond ((eq old-format (fd-stream-external-format stream)) ;; Nothing to do if the new and old formats are the same. ) ((and lisp::*enable-stream-buffer-p* updatep (lisp-stream-string-buffer stream)) ;; We want to reconvert any octets that haven't been converted ;; yet. So, we need to figure out which octet to start with. ;; This is done by converting (the previously converted) octets ;; until we've converted the right number of characters. Or, ;; since we have the octet-count, just sum up them up to figure ;; out how many octets we've already consumed. (let* ((ibuf (lisp-stream-in-buffer stream)) (sindex (lisp-stream-string-index stream)) (octet-count (fd-stream-octet-count stream)) (oc (make-array in-buffer-length :element-type '(unsigned-byte 8))) (index (loop for k of-type fixnum from 0 below (1- sindex) summing (aref octet-count k)))) ;; We now know the last octet that was used. Now convert the ;; rest of the octets using the new format. The new ;; characters are placed in the string buffer at the point ;; just after the last character that we've already read. (multiple-value-bind (s pos count new-state) (stream::octets-to-string-counted ibuf oc :start index :end (fd-stream-in-length stream) :external-format (fd-stream-external-format stream) :string (lisp-stream-string-buffer stream) :s-start sindex :error (fd-stream-octets-to-char-error stream)) (replace octet-count oc :start1 index :end2 pos) (cond ((eq (fd-stream-external-format stream) :iso8859-1) ;; ISO8859-1 doesn't use the string-buffer, so we ;; need to copy the string to the in-buffer and then ;; set the string-buffer to nil to indicate we're not ;; using the string buffer anymore. (let ((index (- in-buffer-length count))) (dotimes (k count) (setf (aref ibuf (+ k index)) (char-code (aref s (+ k sindex))))) (setf (lisp-stream-in-index stream) index) (setf (lisp-stream-string-buffer stream) nil) (setf (lisp-stream-string-buffer-len stream) 0) (setf (lisp-stream-string-index stream) 0))) (t (setf (lisp-stream-string-index stream) sindex) (setf (lisp-stream-string-buffer-len stream) pos) (setf (lisp-stream-in-index stream) (+ index count)) (setf (fd-stream-oc-state stream) new-state)))))) ((and updatep (lisp-stream-in-buffer stream)) ;; This means the external format was ISO8859-1 and we're ;; switching to something else. If so, we need to convert all ;; the octets that haven't been processed yet and place them in ;; the string buffer. We also need to adjust the in-buffer to ;; put those octets in the expected place at the beginning of ;; in-buffer. (let ((index (lisp-stream-in-index stream)) (ibuf (lisp-stream-in-buffer stream))) (setf (lisp-stream-string-buffer stream) (make-string (1+ in-buffer-length))) (setf (lisp-stream-string-index stream) 1) ;; Set the unread char to be the last read octet. (setf (aref (lisp-stream-string-buffer stream) 0) (code-char (aref ibuf (1- index)))) (let ((oc (or (fd-stream-octet-count stream) (setf (fd-stream-octet-count stream) (make-array in-buffer-length :element-type '(unsigned-byte 8)))))) (multiple-value-bind (s pos count new-state) (stream::octets-to-string-counted ibuf oc :start index :external-format (fd-stream-external-format stream) :string (lisp-stream-string-buffer stream) :s-start 1 :error (fd-stream-octets-to-char-error stream)) (declare (ignore s)) (setf (lisp-stream-string-buffer-len stream) pos) (setf (fd-stream-oc-state stream) new-state) ;; Move the octets from the end of the in-buffer to the ;; beginning. Set the index to the number of octets we've ;; processed. (replace ibuf ibuf :start2 index) (setf (lisp-stream-in-index stream) count))))))) extfmt)) (setf lisp::*enable-stream-buffer-p* t) cmucl-21a/src/code/fd-stream.lisp000066400000000000000000002574221260377556400170510ustar00rootroot00000000000000;;; -*- Log: code.log; Package: LISP -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/fd-stream.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Streams for UNIX file descriptors. ;;; ;;; Written by William Lott, July 1989 - January 1990. ;;; Some tuning by Rob MacLachlan. ;;; ;;; ********************************************************************** (in-package "SYSTEM") (intl:textdomain "cmucl") (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream io-timeout beep *beep-function* output-raw-bytes *tty* *stdin* *stdout* *stderr* binary-text-stream)) (in-package "EXTENSIONS") (export '(*backup-extension*)) (in-package "LISP") (export '(file-stream file-string-length)) ;;;; Buffer manipulation routines. (defvar *available-buffers* () "List of available buffers. Each buffer is an sap pointing to bytes-per-buffer of memory.") (defvar lisp::*enable-stream-buffer-p* nil) (defconstant bytes-per-buffer (* 4 1024) "Number of bytes per buffer.") ;; This limit is rather arbitrary (defconstant max-stream-element-size 1024 "The maximum supported byte size for a stream element-type.") ;;; NEXT-AVAILABLE-BUFFER -- Internal. ;;; ;;; Returns the next available buffer, creating one if necessary. ;;; (declaim (inline next-available-buffer)) ;;; (defun next-available-buffer () (if *available-buffers* (pop *available-buffers*) (allocate-system-memory bytes-per-buffer))) (declaim (inline buffer-sap bref (setf bref) buffer-copy)) (defun buffer-sap (thing &optional offset) (declare (type simple-stream-buffer thing) (type (or fixnum null) offset) (optimize (speed 3) (space 2) (debug 0) (safety 0) ;; Suppress the note about having to box up the return: (ext:inhibit-warnings 3))) (let ((sap (if (vectorp thing) (sys:vector-sap thing) thing))) (if offset (sys:sap+ sap offset) sap))) (defun bref (buffer index) (declare (type simple-stream-buffer buffer) (type (integer 0 #.most-positive-fixnum) index)) (sys:sap-ref-8 (buffer-sap buffer) index)) (defun (setf bref) (octet buffer index) (declare (type (unsigned-byte 8) octet) (type simple-stream-buffer buffer) (type (integer 0 #.most-positive-fixnum) index)) (setf (sys:sap-ref-8 (buffer-sap buffer) index) octet)) (defun buffer-copy (src soff dst doff length) (declare (type simple-stream-buffer src dst) (type fixnum soff doff length)) (sys:without-gcing ;; is this necessary?? (kernel:system-area-copy (buffer-sap src) (* soff 8) (buffer-sap dst) (* doff 8) (* length 8)))) #-(or big-endian little-endian) (eval-when (:compile-toplevel) (push (c::backend-byte-order c::*target-backend*) *features*)) (defun vector-elt-width (vector) ;; Return octet-width of vector elements (etypecase vector ;; (simple-array fixnum (*)) not supported ;; (simple-array base-char (*)) treated specially; don't call this ((simple-array bit (*)) 1/8) ((simple-array (unsigned-byte 2) (*)) 1/4) ((simple-array (unsigned-byte 4) (*)) 1/2) ((simple-array (signed-byte 8) (*)) 1) ((simple-array (unsigned-byte 8) (*)) 1) ((simple-array (signed-byte 16) (*)) 2) ((simple-array (unsigned-byte 16) (*)) 2) ((simple-array (signed-byte 32) (*)) 4) ((simple-array (unsigned-byte 32) (*)) 4) ((simple-array single-float (*)) 4) ((simple-array double-float (*)) 8) ((simple-array (complex single-float) (*)) 8) ((simple-array (complex double-float) (*)) 16) #+long-float ((simple-array long-float (*)) 10) #+long-float ((simple-array (complex long-float) (*)) 20) #+double-double ((simple-array double-double-float (*)) 16) #+double-double ((simple-array (complex double-double-float) (*)) 32))) (defun endian-swap-value (vector endian-swap) (case endian-swap (:network-order #+big-endian 0 ;; This is needed because the little-endian (x86) architectures ;; store the lowest indexed element in the least significant part ;; of a byte. On a big-endian machine (sparc, ppc), the lowest ;; indexed element is at the most significant part of a byte. #+little-endian (typecase vector ((array (unsigned-byte 4) (*)) -1) ((array (unsigned-byte 2) (*)) -2) ((array (unsigned-byte 1) (*)) -8) (t (1- (vector-elt-width vector))))) (:byte-8 0) (:byte-16 1) (:byte-32 3) (:byte-64 7) (:byte-128 15) ;; additions by Lynn Quam (:machine-endian 0) (:big-endian #+big-endian 0 #+little-endian (typecase vector ((array (unsigned-byte 4) (*)) -1) ((array (unsigned-byte 2) (*)) -2) ((array (unsigned-byte 1) (*)) -8) (t (1- (vector-elt-width vector))))) (:little-endian #+big-endian (typecase vector ((array (unsigned-byte 4) (*)) -1) ((array (unsigned-byte 2) (*)) -2) ((array (unsigned-byte 1) (*)) -8) (t (1- (vector-elt-width vector)))) #+little-endian 0) (otherwise endian-swap))) ;;;; The FD-STREAM structure. ;;;; Superclass defined by the ANSI Spec (defstruct (file-stream (:include lisp-stream) (:constructor nil) (:copier nil))) (defstruct (fd-stream (:print-function %print-fd-stream) (:constructor %make-fd-stream) (:include file-stream (misc #'fd-stream-misc-routine))) (name nil) ; The name of this stream (file nil) ; The file this stream is for ;; ;; The backup file namestring for the old file, for :if-exists :rename or ;; :rename-and-delete. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete ;; ;;; Number of bytes per element. (element-size 1 :type index) (element-type 'base-char) ; The type of element being transfered. (fd -1 :type fixnum) ; The file descriptor ;; ;; Controls when the output buffer is flushed. (buffering :full :type (member :full :line :none)) ;; ;; Character position if known. (char-pos nil :type (or index null)) ;; ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) ;; ;; The input buffer. (unread nil) (ibuf-sap nil :type (or system-area-pointer null)) (ibuf-length nil :type (or index null)) (ibuf-head 0 :type index) (ibuf-tail 0 :type index) ;; The output buffer. (obuf-sap nil :type (or system-area-pointer null)) (obuf-length nil :type (or index null)) (obuf-tail 0 :type index) ;; Output flushed, but not written due to non-blocking io. (output-later nil) (handler nil) ;; ;; Timeout specified for this stream, or NIL if none. (timeout nil :type (or index null)) ;; ;; Pathname of the file this stream is opened to (returned by PATHNAME.) (pathname nil :type (or pathname null)) ;; ;; External format support ;; ;; @@ I want to use :default here, but keyword pkg isn't set up yet at boot ;; so initialize to NIL and fix it in SET-ROUTINES #+unicode (external-format nil :type (or null keyword cons)) ;; ;; State for octets-to-char (for reading from a stream). The ;; contents of the state can be anything and is defined by the ;; external format. #+unicode (oc-state nil) ;; ;; State for char-to-octets (for writing to a stream). The contents ;; of the state can be anything and is defined by the external ;; format. If not NIL, then the CAR is used by char-to-octets to ;; hold some state information, and the CDR is available to the ;; external format to hold whatever state information is needed. #+unicode (co-state nil) #+unicode (last-char-read-size 0 :type index) ;; ;; The number of octets in in-buffer. Normally equal to ;; in-buffer-length, but could be less if we reached the ;; end-of-file. #+unicode (in-length in-buffer-length :type index) ;; ;; Indicates how to handle errors when converting octets to ;; characters. If NIL, then the external format should handle it ;; itself, doing whatever is deemed appropriate. If non-NIL, this ;; should be a function (or symbol) that the external format can ;; funcall to deal with the error. The function should take three ;; arguments: a message string, the offending octet, and the number ;; of octets read so far in decoding; if the function returns it ;; should return the codepoint of the desired replacement character. (octets-to-char-error nil :type (or null symbol function)) ;; ;; Like OCTETS-TO-CHAR-ERROR, but for converting characters to ;; octets for output. The function takes two arguments: a message ;; string and the codepoint that cannot be converted. The function ;; should return the octet that should be output. (char-to-octets-error nil :type (or null symbol function))) (defun %print-fd-stream (fd-stream stream depth) (declare (ignore depth) (stream stream)) (format stream "#" (fd-stream-name fd-stream))) ;; CMUCL extension. This is a FD-STREAM, but it allows reading and ;; writing of 8-bit characters and unsigned bytes from the stream. (defstruct (binary-text-stream (:print-function %print-binary-text-stream) (:constructor %make-binary-text-stream) (:include fd-stream))) (defun %print-binary-text-stream (fd-stream stream depth) (declare (ignore depth) (stream stream)) (format stream "#" (fd-stream-name fd-stream))) (define-condition io-timeout (stream-error) ((direction :reader io-timeout-direction :initarg :direction)) (:report (lambda (condition stream) (declare (stream stream)) (format stream (intl:gettext "Timeout ~(~A~)ing ~S.") (io-timeout-direction condition) (stream-error-stream condition))))) ;;;; Output routines and related noise. (defvar *output-routines* () "List of all available output routines. Each element is a list of the element-type output, the kind of buffering, the function name, and the number of bytes per element.") ;;; DO-OUTPUT-LATER -- internal ;;; ;;; Called by the server when we can write to the given file descriptor. ;;; Attempt to write the data again. If it worked, remove the data from the ;;; output-later list. If it didn't work, something is wrong. ;;; (defun do-output-later (stream) (let* ((stuff (pop (fd-stream-output-later stream))) (base (car stuff)) (start (cadr stuff)) (end (caddr stuff)) (reuse-sap (cadddr stuff)) (length (- end start))) (declare (type index start end length)) (multiple-value-bind (count errno) (unix:unix-write (fd-stream-fd stream) base start length) (cond ((not count) (if (= errno unix:ewouldblock) (error (intl:gettext "Write would have blocked, but SERVER told us to go.")) (error (intl:gettext "While writing ~S: ~A") stream (unix:get-unix-error-msg errno)))) ((eql count length) ; Hot damn, it worked. (when reuse-sap (push base *available-buffers*))) ((not (null count)) ; Sorta worked. (push (list base (the index (+ start count)) end) (fd-stream-output-later stream)))))) (unless (fd-stream-output-later stream) (system:remove-fd-handler (fd-stream-handler stream)) (setf (fd-stream-handler stream) nil))) ;;; OUTPUT-LATER -- internal ;;; ;;; Arrange to output the string when we can write on the file descriptor. ;;; (defun output-later (stream base start end reuse-sap) (cond ((null (fd-stream-output-later stream)) (setf (fd-stream-output-later stream) (list (list base start end reuse-sap))) (setf (fd-stream-handler stream) (system:add-fd-handler (fd-stream-fd stream) :output #'(lambda (fd) (declare (ignore fd)) (do-output-later stream))))) (t (nconc (fd-stream-output-later stream) (list (list base start end reuse-sap))))) (when reuse-sap (let ((new-buffer (next-available-buffer))) (setf (fd-stream-obuf-sap stream) new-buffer) (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) ;;; DO-OUTPUT -- internal ;;; ;;; Output the given noise. Check to see if there are any pending writes. If ;;; so, just queue this one. Otherwise, try to write it. If this would block, ;;; queue it. ;;; (defun do-output (stream base start end reuse-sap) (declare (type fd-stream stream) (type (or system-area-pointer (simple-array * (*))) base) (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. (progn (output-later stream base start end reuse-sap) ;; ### check to see if any of this noise can be output ) (let ((length (- end start))) (multiple-value-bind (count errno) (unix:unix-write (fd-stream-fd stream) base start length) (cond ((not count) (if (= errno unix:ewouldblock) (output-later stream base start end reuse-sap) (error 'simple-stream-error :stream stream :format-control "while writing: ~A" :format-arguments (list (unix:get-unix-error-msg errno))))) ((not (eql count length)) (output-later stream base (the index (+ start count)) end reuse-sap))))))) #+unicode (stream::def-ef-macro ef-flush (extfmt lisp stream::+ef-max+ stream::+ef-flush+) `(lambda (stream) (declare (type fd-stream stream)) (let* ((tail (fd-stream-obuf-tail stream))) (declare (type index tail)) (cond ((stream::ef-flush-state ,(stream::find-external-format extfmt)) (let* ((sap (fd-stream-obuf-sap stream)) (len (fd-stream-obuf-length stream))) (declare (type sys:system-area-pointer sap) (type index len) (ignorable sap len)) (stream::flush-state ,extfmt (fd-stream-co-state stream) (lambda (byte) (when (= tail len) (do-output stream sap 0 tail t) (setq sap (fd-stream-obuf-sap stream) tail 0)) (setf (bref sap (1- (incf tail))) byte)) (fd-stream-char-to-octets-error stream)) (setf (fd-stream-obuf-tail stream) tail))) (t ;; No flush-state function, so just output a replacement ;; character (or signal an error). We hack the co-state to ;; what we need for this to work. This should be ok because ;; we're closing the file anyway. (let* ((state (fd-stream-co-state stream)) (c (car state))) (when (and state c) (setf (fd-stream-co-state stream) (cons nil (cdr state))) (funcall (ef-cout (fd-stream-external-format stream)) stream ;; Handle bare surrogates or use the ;; replacement character. (if (lisp::surrogatep c) (if (fd-stream-char-to-octets-error stream) (funcall (fd-stream-char-to-octets-error stream) "Flushing bare surrogate #x~4,0X is illegal" (char-code c)) (code-char stream:+replacement-character-code+)) c)))))) (values)))) ;;; FLUSH-OUTPUT-BUFFER -- internal ;;; ;;; Flush any data in the output buffer. ;;; (defun flush-output-buffer (stream) (let ((length (fd-stream-obuf-tail stream))) (unless (= length 0) (do-output stream (fd-stream-obuf-sap stream) 0 length t) (setf (fd-stream-obuf-tail stream) 0)))) ;;; DEF-OUTPUT-ROUTINES -- internal ;;; ;;; Define output routines that output numbers size bytes long for the ;;; given bufferings. Use body to do the actual output. ;;; (defmacro def-output-routines ((name size &rest bufferings) &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar #'(lambda (buffering) (let ((function (intern (let ((*print-case* :upcase)) (format nil name (car buffering)))))) `(progn (defun ,function (stream byte) ,(unless (eq (car buffering) :none) `(when (< (fd-stream-obuf-length stream) (+ (fd-stream-obuf-tail stream) ,size)) (flush-output-buffer stream))) ;; ;; If there is any input read from UNIX but not ;; supplied to the user of the stream, reposition ;; to the real file position as seen from Lisp. ,(unless (eq (car buffering) :none) `(when (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream)) (file-position stream (file-position stream)))) ,@body (incf (fd-stream-obuf-tail stream) ,size) ,(ecase (car buffering) (:none `(flush-output-buffer stream)) (:line `(when (eql (char-code byte) (char-code #\Newline)) (flush-output-buffer stream))) (:full )) (values)) (setf *output-routines* (nconc *output-routines* ',(mapcar #'(lambda (type) (list type (car buffering) function size)) (cdr buffering))))))) bufferings))) #-unicode (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 (:none character) (:line character) (:full character)) (if (char= byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) (char-code byte))) #+unicode (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 (:none character) (:line character) (:full character)) (if (char= byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) ;; FIXME! We only use the low 8 bits of a character! (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) (logand #xff (char-code byte)))) (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" 1 (:none (unsigned-byte 8)) (:full (unsigned-byte 8))) (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" 1 (:none (signed-byte 8)) (:full (signed-byte 8))) (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" 2 (:none (unsigned-byte 16)) (:full (unsigned-byte 16))) (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" 2 (:none (signed-byte 16)) (:full (signed-byte 16))) (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" 4 (:none (unsigned-byte 32)) (:full (unsigned-byte 32))) (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" 4 (:none (signed-byte 32)) (:full (signed-byte 32))) (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) byte)) (stream::def-ef-macro ef-cout (extfmt lisp stream::+ef-max+ stream::+ef-cout+) `(lambda (stream char) (declare (type fd-stream stream) (type character char) (optimize (speed 3) (space 0) (debug 0) (safety 0))) ;; If there is any input read from UNIX but not ;; supplied to the user of the stream, reposition ;; to the real file position as seen from Lisp. (when (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream)) (file-position stream (file-position stream))) (let* ((sap (fd-stream-obuf-sap stream)) (len (fd-stream-obuf-length stream)) (tail (fd-stream-obuf-tail stream))) (declare (type sys:system-area-pointer sap) (type index len tail)) (stream::char-to-octets ,extfmt char (fd-stream-co-state stream) (lambda (byte) (when (= tail len) (do-output stream sap 0 tail t) (setq sap (fd-stream-obuf-sap stream) tail 0)) (setf (bref sap (1- (incf tail))) byte)) (fd-stream-char-to-octets-error stream)) (setf (fd-stream-obuf-tail stream) tail)) (if (char= char #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (ecase (fd-stream-buffering stream) (:none (flush-output-buffer stream)) (:line (when (char= char #\Newline) (flush-output-buffer stream))) (:full #| do nothing |#)) (values))) ;;; OUTPUT-RAW-BYTES -- public ;;; ;;; Does the actual output. If there is space to buffer the string, buffer ;;; it. If the string would normally fit in the buffer, but doesn't because ;;; of other stuff in the buffer, flush the old noise out of the buffer and ;;; put the string in it. Otherwise we have a very long string, so just ;;; send it directly (after flushing the buffer, of course). ;;; (defun output-raw-bytes (stream thing &optional start end) "Output THING to stream. THING can be any kind of vector or a sap. If THING is a SAP, END must be supplied (as length won't work)." (let ((start (or start 0)) (end (or end (length (the (simple-array * (*)) thing))))) (declare (type index start end)) ;; ;; If there is any input read from UNIX but not ;; supplied to the user of the stream, reposition ;; to the real file position as seen from Lisp. (when (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream)) (file-position stream (file-position stream))) (let* ((len (fd-stream-obuf-length stream)) (tail (fd-stream-obuf-tail stream)) (space (- len tail)) (bytes (- end start)) (newtail (+ tail bytes))) (cond ((minusp bytes) ; Error case (cerror (intl:gettext "Just go on as if nothing happened...") (intl:gettext "~S called with :END before :START!") 'output-raw-bytes)) ((zerop bytes)) ; Easy case ((<= bytes space) (if (system-area-pointer-p thing) (system-area-copy thing (* start vm:byte-bits) (fd-stream-obuf-sap stream) (* tail vm:byte-bits) (* bytes vm:byte-bits)) (copy-to-system-area thing (+ (* start vm:byte-bits) (* vm:vector-data-offset vm:word-bits)) (fd-stream-obuf-sap stream) (* tail vm:byte-bits) (* bytes vm:byte-bits))) (setf (fd-stream-obuf-tail stream) newtail)) ((<= bytes len) (flush-output-buffer stream) (if (system-area-pointer-p thing) (system-area-copy thing (* start vm:byte-bits) (fd-stream-obuf-sap stream) 0 (* bytes vm:byte-bits)) (copy-to-system-area thing (+ (* start vm:byte-bits) (* vm:vector-data-offset vm:word-bits)) (fd-stream-obuf-sap stream) 0 (* bytes vm:byte-bits))) (setf (fd-stream-obuf-tail stream) bytes)) (t (flush-output-buffer stream) (do-output stream thing start end nil)))))) ;;; FD-SOUT -- internal ;;; ;;; Routine to use to output a string. If the stream is unbuffered, slam ;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to ;;; buffer the string. Update charpos by checking to see where the last newline ;;; was. ;;; ;;; Note: some bozos (the FASL dumper) call write-string with things other ;;; than strings. Therefore, we must make sure we have a string before calling ;;; position on it. ;;; (stream::def-ef-macro ef-sout (extfmt lisp stream::+ef-max+ stream::+ef-sout+) `(lambda (stream string start end) (declare (type fd-stream stream) (type simple-string string) (type index start end) (optimize (speed 3) (space 0) (safety 0) (debug 0))) ;; If there is any input read from UNIX but not ;; supplied to the user of the stream, reposition ;; to the real file position as seen from Lisp. ;; (maybe the caller should do this?) (when (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream)) (file-position stream (file-position stream))) (let* ((sap (fd-stream-obuf-sap stream)) (len (fd-stream-obuf-length stream)) (tail (fd-stream-obuf-tail stream))) (declare (type sys:system-area-pointer sap) (type index len tail)) (dotimes (i (- end start)) (stream::char-to-octets ,extfmt (schar string (+ i start)) (fd-stream-co-state stream) (lambda (byte) (when (= tail len) (do-output stream sap 0 tail t) (setq sap (fd-stream-obuf-sap stream) tail 0)) (setf (bref sap (1- (incf tail))) byte)) (fd-stream-char-to-octets-error stream))) (setf (fd-stream-obuf-tail stream) tail)))) #-unicode (defun fd-sout (stream thing start end) (let ((start (or start 0)) (end (or end (length (the vector thing))))) (declare (type index start end)) (if (stringp thing) (let ((last-newline (and (find #\newline (the simple-string thing) :start start :end end) (position #\newline (the simple-string thing) :from-end t :start start :end end)))) (ecase (fd-stream-buffering stream) (:full (output-raw-bytes stream thing start end)) (:line (output-raw-bytes stream thing start end) (when last-newline (flush-output-buffer stream))) (:none (do-output stream thing start end nil))) (if last-newline (setf (fd-stream-char-pos stream) (- end last-newline 1)) (incf (fd-stream-char-pos stream) (- end start)))) (ecase (fd-stream-buffering stream) ((:line :full) (output-raw-bytes stream thing start end)) (:none (do-output stream thing start end nil)))))) #+unicode ;; Temporary. The final version is defined in fd-stream-extfmt.lisp (defun fd-sout (stream thing start end) (declare (type string thing)) (let ((start (or start 0)) (end (or end (length (the vector thing))))) (declare (type index start end)) (cond ((stringp thing) ; FIXME - remove this test (let ((out (fd-stream-out stream))) (do ((index start (+ index 1))) ((>= index end)) (funcall out stream (elt thing index)))))))) (defmacro output-wrapper ((stream size buffering) &body body) (let ((stream-var (gensym))) `(let ((,stream-var ,stream)) ,(unless (eq (car buffering) :none) `(when (< (fd-stream-obuf-length ,stream-var) (+ (fd-stream-obuf-tail ,stream-var) ,size)) (flush-output-buffer ,stream-var))) ,(unless (eq (car buffering) :none) `(when (> (fd-stream-ibuf-tail ,stream-var) (fd-stream-ibuf-head ,stream-var)) (file-position ,stream-var (file-position ,stream-var)))) ,@body (incf (fd-stream-obuf-tail ,stream-var) ,size) ,(ecase (car buffering) (:none `(flush-output-buffer ,stream-var)) (:line `(when (eq (char-code byte) (char-code #\Newline)) (flush-output-buffer ,stream-var))) (:full)) (values)))) ;;; PICK-OUTPUT-ROUTINE -- internal ;;; ;;; Find an output routine to use given the type and buffering. Return as ;;; multiple values the routine, the real type transfered, and the number of ;;; bytes per element. ;;; (defun pick-output-routine (type buffering) (dolist (entry *output-routines*) (when (and (subtypep type (car entry)) (eq buffering (cadr entry))) (return-from pick-output-routine (values (symbol-function (caddr entry)) (car entry) (cadddr entry))))) ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE) if (subtypep type `(unsigned-byte ,i)) do (return-from pick-output-routine (values (ecase buffering (:none (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none)) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) (+ j (fd-stream-obuf-tail stream))) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full)) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) (+ j (fd-stream-obuf-tail stream))) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(unsigned-byte ,i) (/ i 8)))) (loop for i from 40 by 8 to max-stream-element-size ; ARB (KLUDGE) if (subtypep type `(signed-byte ,i)) do (return-from pick-output-routine (values (ecase buffering (:none (lambda (stream byte) (output-wrapper (stream (/ i 8) (:none)) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) (+ j (fd-stream-obuf-tail stream))) (ldb (byte 8 (- i 8 (* j 8))) byte)))))) (:full (lambda (stream byte) (output-wrapper (stream (/ i 8) (:full)) (loop for j from 0 below (/ i 8) do (setf (sap-ref-8 (fd-stream-obuf-sap stream) (+ j (fd-stream-obuf-tail stream))) (ldb (byte 8 (- i 8 (* j 8))) byte))))))) `(signed-byte ,i) (/ i 8))))) ;;;; Input routines and related noise. (defvar *input-routines* () "List of all available input routines. Each element is a list of the element-type input, the function name, and the number of bytes per element.") ;;; DO-INPUT -- internal ;;; ;;; Fills the input buffer, and returns the first character. Throws to ;;; eof-input-catcher if the eof was reached. Drops into system:server if ;;; necessary. ;;; (defun do-input (stream) (let ((fd (fd-stream-fd stream)) (ibuf-sap (fd-stream-ibuf-sap stream)) (buflen (fd-stream-ibuf-length stream)) (head (fd-stream-ibuf-head stream)) (lcrs #-unicode 0 #+unicode (fd-stream-last-char-read-size stream)) (tail (fd-stream-ibuf-tail stream))) (declare (type index head lcrs tail)) (unless (zerop head) (cond ((eql head tail) (setf head lcrs) (setf tail lcrs) (setf (fd-stream-ibuf-head stream) lcrs) (setf (fd-stream-ibuf-tail stream) lcrs)) (t (decf tail (- head lcrs)) (system-area-copy ibuf-sap (* (- head lcrs) vm:byte-bits) ibuf-sap 0 (* tail vm:byte-bits)) (setf head lcrs) (setf (fd-stream-ibuf-head stream) lcrs) (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) (multiple-value-bind (count errno) (alien:with-alien ((read-fds (alien:struct unix:fd-set))) (unix:fd-zero read-fds) (unix:fd-set fd read-fds) (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0)) ;; Wait if input is not available or if interrupted. (when (or (eql count 0) (and (not count) (eql errno unix:eintr))) (unless #-mp (system:wait-until-fd-usable fd :input (fd-stream-timeout stream)) #+mp (mp:process-wait-until-fd-usable fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read)))) (multiple-value-bind (count errno) (unix:unix-read fd (system:int-sap (+ (system:sap-int ibuf-sap) tail)) (- buflen tail)) (cond ((null count) ;; What kinds of errors do we want to look at and what do ;; we want them to do? (cond ((eql errno unix:ewouldblock) (unless #-mp (system:wait-until-fd-usable fd :input (fd-stream-timeout stream)) #+mp (mp:process-wait-until-fd-usable fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read)) (do-input stream)) ((eql errno unix:econnreset) (error 'socket-error :format-control "Socket connection reset: ~A" :format-arguments (list (unix:get-unix-error-msg errno)) :errno errno)) (t (error (intl:gettext "Error reading ~S: ~A") stream (unix:get-unix-error-msg errno))))) ((zerop count) (setf (fd-stream-listen stream) :eof) (throw 'eof-input-catcher nil)) (t (incf (fd-stream-ibuf-tail stream) count)))))) ;;; INPUT-AT-LEAST -- internal ;;; ;;; Makes sure there are at least ``bytes'' number of bytes in the input ;;; buffer. Keeps calling do-input until that condition is met. ;;; (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) (bytes-var (gensym))) `(let ((,stream-var ,stream) (,bytes-var ,bytes)) (loop (when (>= (- (fd-stream-ibuf-tail ,stream-var) (fd-stream-ibuf-head ,stream-var)) ,bytes-var) (return)) (do-input ,stream-var))))) ;;; INPUT-WRAPPER -- internal ;;; ;;; Macro to wrap around all input routines to handle eof-error noise. ;;; (defmacro input-wrapper ((stream bytes eof-error eof-value &optional type) &body read-forms) (let ((stream-var (gensym)) (element-var (gensym))) `(let ((,stream-var ,stream)) (if (fd-stream-unread ,stream-var) ;;@@ (prog1 ,(if (eq type 'character) `(fd-stream-unread ,stream-var) `(char-code (fd-stream-unread ,stream-var))) (setf (fd-stream-unread ,stream-var) nil) (setf (fd-stream-listen ,stream-var) nil)) (let ((,element-var (catch 'eof-input-catcher (input-at-least ,stream-var ,bytes) ,@read-forms))) (cond (,element-var (incf (fd-stream-ibuf-head ,stream-var) ,bytes) ,element-var) (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) ;;; DEF-INPUT-ROUTINE -- internal ;;; ;;; Defines an input routine. ;;; (defmacro def-input-routine (name (type size sap head) &rest body) `(progn (defun ,name (stream eof-error eof-value) (input-wrapper (stream ,size eof-error eof-value ,type) (let ((,sap (fd-stream-ibuf-sap stream)) (,head (fd-stream-ibuf-head stream))) ,@body))) (setf *input-routines* (nconc *input-routines* (list (list ',type ',name ',size)))))) ;;; INPUT-CHARACTER -- internal ;;; ;;; Routine to use in stream-in slot for reading string chars. ;;; (def-input-routine input-character (character 1 sap head) (code-char (sap-ref-8 sap head))) ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal ;;; ;;; Routine to read in an unsigned 8 bit number. ;;; (def-input-routine input-unsigned-8bit-byte ((unsigned-byte 8) 1 sap head) (sap-ref-8 sap head)) ;;; INPUT-SIGNED-8BIT-BYTE -- internal ;;; ;;; Routine to read in a signed 8 bit number. ;;; (def-input-routine input-signed-8bit-number ((signed-byte 8) 1 sap head) (signed-sap-ref-8 sap head)) ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal ;;; ;;; Routine to read in an unsigned 16 bit number. ;;; (def-input-routine input-unsigned-16bit-byte ((unsigned-byte 16) 2 sap head) (sap-ref-16 sap head)) ;;; INPUT-SIGNED-16BIT-BYTE -- internal ;;; ;;; Routine to read in a signed 16 bit number. ;;; (def-input-routine input-signed-16bit-byte ((signed-byte 16) 2 sap head) (signed-sap-ref-16 sap head)) ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal ;;; ;;; Routine to read in a unsigned 32 bit number. ;;; (def-input-routine input-unsigned-32bit-byte ((unsigned-byte 32) 4 sap head) (sap-ref-32 sap head)) ;;; INPUT-SIGNED-32BIT-BYTE -- internal ;;; ;;; Routine to read in a signed 32 bit number. ;;; (def-input-routine input-signed-32bit-byte ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+) `(lambda (stream eof-error-p eof-value) (declare (type fd-stream stream) #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#) (let* ((head (fd-stream-ibuf-head stream)) (ch (catch 'eof-input-catcher (stream::octets-to-char ,extfmt (fd-stream-oc-state stream) (fd-stream-last-char-read-size stream) ;;@@ Note: need proper EOF handling... (progn (when (= head (fd-stream-ibuf-tail stream)) (let ((sofar (- head (fd-stream-ibuf-head stream)))) (do-input stream) (setf head (+ (fd-stream-ibuf-head stream) sofar)))) (bref (fd-stream-ibuf-sap stream) (1- (incf head)))) (lambda (n) (decf head n)))))) (declare (type index head)) (if ch (progn (setf (fd-stream-ibuf-head stream) head) ch) (eof-or-lose stream eof-error-p eof-value))))) #+(or) (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+) `(lambda (stream string char start end) (declare (type fd-stream stream) (type simple-string string) (type (or character null) char) (type index start end) (optimize (speed 3) (space 0) (debug 0) (safety 0))) (let ((sap (fd-stream-ibuf-sap stream)) (head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (curr start)) (declare (type sys:system-area-pointer sap) (type index head tail curr)) (loop ;;@@ Fix EOF handling (let* ((sz 0) (ch (catch 'eof-input-catcher (stream::octets-to-char ,extfmt (fd-stream-oc-state stream) sz (progn (when (= head tail) (let ((sofar (- head (fd-stream-ibuf-head stream)))) (do-input stream) (setq head (+ (fd-stream-ibuf-head stream) sofar) tail (fd-stream-ibuf-tail stream)))) (bref sap (1- (incf head)))) (lambda (n) (decf head n)))))) (declare (type index sz) (type (or null character) ch)) (when (null ch) (return (values (- curr start) :eof))) (setf (fd-stream-last-char-read-size stream) sz) (incf (fd-stream-ibuf-head stream) sz) (when (and char (char= ch char)) (return (values (- curr start) t))) (setf (schar string (1- (incf curr))) ch) (when (= curr end) (return (values (- curr start) nil)))))))) ;;; PICK-INPUT-ROUTINE -- internal ;;; ;;; Find an input routine to use given the type. Return as multiple values ;;; the routine, the real type transfered, and the number of bytes per element. ;;; (defun pick-input-routine (type) (dolist (entry *input-routines*) (when (subtypep type (car entry)) (return-from pick-input-routine (values (symbol-function (cadr entry)) (car entry) (caddr entry))))) ;; FIXME: let's do it the hard way, then (but ignore things like ;; endianness, efficiency, and the necessary coupling between these ;; and the output routines). -- CSR, 2004-02-09 (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really) if (subtypep type `(unsigned-byte ,i)) do (return-from pick-input-routine (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) (let ((sap (fd-stream-ibuf-sap stream)) (head (fd-stream-ibuf-head stream))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result (+ (* 256 result) (sap-ref-8 sap (+ head j)))) finally (return result))))) `(unsigned-byte ,i) (/ i 8)))) (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really) if (subtypep type `(signed-byte ,i)) do (return-from pick-input-routine (values (lambda (stream eof-error eof-value) (input-wrapper (stream (/ i 8) eof-error eof-value) (let ((sap (fd-stream-ibuf-sap stream)) (head (fd-stream-ibuf-head stream))) (loop for j from 0 below (/ i 8) with result = 0 do (setf result (+ (* 256 result) (sap-ref-8 sap (+ head j)))) finally (return (if (logbitp (1- i) result) (dpb result (byte i 0) -1) result)))))) `(signed-byte ,i) (/ i 8))))) ;;; STRING-FROM-SAP -- internal ;;; ;;; Returns a string constructed from the sap, start, and end. ;;; (defun string-from-sap (sap start end) (declare (type index start end)) (let* ((length (- end start)) (string (make-string length))) (copy-from-system-area sap (* start vm:byte-bits) string (* vm:vector-data-offset vm:word-bits) (* length vm:byte-bits)) string)) #| ;;; FD-STREAM-READ-N-BYTES -- internal ;;; ;;; This version waits using server. I changed to the non-server version ;;; because it allows this method to be used by CLX w/o confusing serve-event. ;;; The non-server method is also significantly more efficient for large ;;; reads. -- Ram ;;; ;;; The n-bin routine. ;;; (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type stream stream) (type index start requested)) (let* ((sap (fd-stream-ibuf-sap stream)) (elsize (fd-stream-element-size stream)) (offset (* elsize start)) (bytes (* elsize requested)) (result (catch 'eof-input-catcher (loop (input-at-least stream 1) (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (available (- tail head)) (copy (min available bytes))) (if (typep buffer 'system-area-pointer) (system-area-copy sap (* head vm:byte-bits) buffer (* offset vm:byte-bits) (* copy vm:byte-bits)) (copy-from-system-area sap (* head vm:byte-bits) buffer (+ (* offset vm:byte-bits) (* vm:vector-data-offset vm:word-bits)) (* copy vm:byte-bits))) (incf (fd-stream-ibuf-head stream) copy) (incf offset copy) (decf bytes copy)) (when (zerop bytes) (return requested)))))) (or result (eof-or-lose stream eof-error-p (- requested (/ bytes elsize)))))) |# ;;; FD-STREAM-READ-N-BYTES -- internal ;;; ;;; The N-Bin method for FD-STREAMs. This doesn't use the SERVER; it blocks ;;; in UNIX-READ. This allows the method to be used to implement reading ;;; for CLX. It is generally used where there is a definite amount of reading ;;; to be done, so blocking isn't too problematical. ;;; ;;; We copy buffered data into the buffer. If there is enough, just return. ;;; Otherwise, we see if the amount of additional data needed will fit in the ;;; stream buffer. If not, inhibit GCing (so we can have a SAP into the Buffer ;;; argument), and read directly into the user supplied buffer. Otherwise, ;;; read a buffer-full into the stream buffer and then copy the amount we need ;;; out. ;;; ;;; We loop doing the reads until we either get enough bytes or hit EOF. We ;;; must loop when eof-errorp is T because some streams (like pipes) may return ;;; a partial amount without hitting EOF. ;;; (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type stream stream) (type index start requested)) (let* ((sap (fd-stream-ibuf-sap stream)) (offset start) (head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (available (- tail head)) (copy (min requested available))) (declare (type index offset head tail available copy)) ;; ;; If something has been unread, put that at buffer + start, ;; and read the rest to start + 1. (when (fd-stream-unread stream) ;;@@ (etypecase buffer (system-area-pointer (assert (= 1 (fd-stream-element-size stream))) (setf (sap-ref-8 buffer start) (char-code (read-char stream)))) (string (setf (aref buffer start) (read-char stream))) (vector (setf (aref buffer start) (char-code(read-char stream))))) (return-from fd-stream-read-n-bytes (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested) eof-error-p)))) ;; (unless (zerop copy) (if (typep buffer 'system-area-pointer) (system-area-copy sap (* head vm:byte-bits) buffer (* offset vm:byte-bits) (* copy vm:byte-bits)) (copy-from-system-area sap (* head vm:byte-bits) buffer (+ (* offset vm:byte-bits) (* vm:vector-data-offset vm:word-bits)) (* copy vm:byte-bits))) (incf (fd-stream-ibuf-head stream) copy)) (cond ((or (= copy requested) (and (not eof-error-p) (/= copy 0))) copy) (t (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) (setf (fd-stream-listen stream) nil) (let ((now-needed (- requested copy)) (len (fd-stream-ibuf-length stream))) (declare (type index now-needed len)) (cond ((> now-needed len) ;; ;; If the desired amount is greater than the stream buffer size, then ;; read directly into the destination, incrementing the start ;; accordingly. In this case, we never leave anything in the stream ;; buffer. (system:without-gcing (loop (multiple-value-bind (count err) (unix:unix-read (fd-stream-fd stream) (sap+ (if (typep buffer 'system-area-pointer) buffer (vector-sap buffer)) (+ offset copy)) now-needed) (declare (type (or index null) count)) (unless count (error (intl:gettext "Error reading ~S: ~A") stream (unix:get-unix-error-msg err))) (decf now-needed count) (if eof-error-p (when (zerop count) (error 'end-of-file :stream stream)) (return (- requested now-needed))) (when (zerop now-needed) (return requested)) (incf offset count))))) (t ;; ;; If we want less than the buffer size, then loop trying to fill the ;; stream buffer and copying what we get into the destination. When ;; we have enough, we leave what's left in the stream buffer. (loop (multiple-value-bind (count err) (unix:unix-read (fd-stream-fd stream) sap len) (declare (type (or index null) count)) (unless count (error (intl:gettext "Error reading ~S: ~A") stream (unix:get-unix-error-msg err))) (when (and eof-error-p (zerop count)) (error 'end-of-file :stream stream)) (let* ((copy (min now-needed count)) (copy-bits (* copy vm:byte-bits)) (buffer-start-bits (* (+ offset available) vm:byte-bits))) (declare (type index copy copy-bits buffer-start-bits)) (if (typep buffer 'system-area-pointer) (system-area-copy sap 0 buffer buffer-start-bits copy-bits) (copy-from-system-area sap 0 buffer (+ buffer-start-bits (* vm:vector-data-offset vm:word-bits)) copy-bits)) (decf now-needed copy) (when (or (zerop now-needed) (not eof-error-p)) (setf (fd-stream-ibuf-head stream) copy) (setf (fd-stream-ibuf-tail stream) count) (return (- requested now-needed))) (incf offset copy))))))))))) ;;;; Utility functions (misc routines, etc) ;;; SET-ROUTINES -- internal ;;; ;;; Fill in the various routine slots for the given type. Input-p and ;;; output-p indicate what slots to fill. The buffering slot must be set prior ;;; to calling this routine. ;;; (defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p) (let ((target-type (case type ((:default unsigned-byte) '(unsigned-byte 8)) (signed-byte '(signed-byte 8)) (t type))) (input-type nil) (output-type nil) (input-size nil) (output-size nil)) (when (fd-stream-obuf-sap stream) (push (fd-stream-obuf-sap stream) *available-buffers*) (setf (fd-stream-obuf-sap stream) nil)) (when (fd-stream-ibuf-sap stream) (push (fd-stream-ibuf-sap stream) *available-buffers*) (setf (fd-stream-ibuf-sap stream) nil)) #+unicode (when (null (fd-stream-external-format stream)) (setf (fd-stream-external-format stream) :default)) (when input-p (multiple-value-bind (routine type size) (pick-input-routine target-type) (unless routine (error (intl:gettext "Could not find any input routine for ~S") target-type)) (setf (fd-stream-ibuf-sap stream) (next-available-buffer)) (setf (fd-stream-ibuf-length stream) bytes-per-buffer) (setf (fd-stream-ibuf-tail stream) 0) ;; Set the in and bin methods. Normally put an illegal input ;; function in, but if we have a binary text stream, pick an ;; appropriate input routine. (if (subtypep type 'character) (setf (fd-stream-in stream) routine (fd-stream-bin stream) (if (and binary-stream-p (eql size 1)) (pick-input-routine '(unsigned-byte 8)) #'ill-bin)) (setf (fd-stream-in stream) (if (and binary-stream-p (eql size 1)) (pick-input-routine 'character) #'ill-in) (fd-stream-bin stream) routine)) (when (or (eql size 1) (eql size 2) (eql size 4)) ;; Support for n-byte operations on 8-, 16-, and 32-bit streams (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes) (when (and buffer-p (eql size 1) (or ;; FIXME: Do this better. We want to check for ;; (unsigned-byte 8). The 8 is unnecessary ;; since we already have size = 1. (or (eq 'unsigned-byte (and (consp type) (car type))) (eq type :default)) (eq type 'character))) (when *enable-stream-buffer-p* (when (and (not binary-stream-p) (eq type 'character)) ;; Create the in-buffer for any character (only) ;; stream. Don't want one for binary-text-streams! (setf (lisp-stream-in-buffer stream) (make-array in-buffer-length :element-type '(unsigned-byte 8)))) #+unicode (when (and (not binary-stream-p) (eq type 'character) (not (eq :iso8859-1 (fd-stream-external-format stream)))) ;; For character streams, we create the string-buffer so ;; we can convert all available octets at once instead ;; of for each character. The string is one element ;; longer than in-buffer-length to leave room for ;; unreading. ;; ;; For ISO8859-1, we don't want this because it's very ;; easy and quick to convert octets to iso8859-1. (See ;; FAST-READ-CHAR.) (setf (lisp-stream-string-buffer stream) (make-string (1+ in-buffer-length))) (setf (fd-stream-octet-count stream) (make-array in-buffer-length :element-type '(unsigned-byte 8))) (setf (lisp-stream-string-buffer-len stream) 0) (setf (lisp-stream-string-index stream) 0))))) (setf input-size size) (setf input-type type))) (when output-p (multiple-value-bind (routine type size) (pick-output-routine target-type (fd-stream-buffering stream)) (unless routine (error (intl:gettext "Could not find any output routine for ~S buffered ~S.") (fd-stream-buffering stream) target-type)) (setf (fd-stream-obuf-sap stream) (next-available-buffer)) (setf (fd-stream-obuf-length stream) bytes-per-buffer) (setf (fd-stream-obuf-tail stream) 0) ;; Normally signal errors for reading from a stream with the ;; wrong element type, but allow binary-text-streams to read ;; from either. (if (subtypep type 'character) (setf (fd-stream-out stream) routine (fd-stream-bout stream) (if (and binary-stream-p (eql size 1)) (pick-output-routine '(unsigned-byte 8) (fd-stream-buffering stream)) #'ill-bout)) (setf (fd-stream-out stream) (if (and binary-stream-p (eql size 1)) (pick-output-routine 'base-char (fd-stream-buffering stream)) #'ill-out) (fd-stream-bout stream) routine)) (setf (fd-stream-sout stream) (if (eql size 1) #'fd-sout #'ill-out)) (setf (fd-stream-char-pos stream) 0) (setf output-size size) (setf output-type type))) (when (and input-size output-size (not (eql input-size output-size))) (error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?") input-type input-size output-type output-size)) (setf (fd-stream-element-size stream) (or input-size output-size)) (setf (fd-stream-element-type stream) (cond ((equal input-type output-type) input-type) ((null output-type) input-type) ((null input-type) output-type) ((subtypep input-type output-type) input-type) ((subtypep output-type input-type) output-type) (t (error (intl:gettext "Input type (~S) and output type (~S) are unrelated?") input-type output-type)))))) ;;; REVERT-FILE -- internal ;;; ;;; Revert a file, if possible; otherwise do nothing. Used during ;;; CLOSE when the abort flag is set. ;;; (defun revert-file (filename original) (declare (type simple-base-string filename) (type (or simple-base-string null) original)) (when original (multiple-value-bind (okay err) (unix:unix-rename original filename) (unless okay (cerror (intl:gettext "Go on as if nothing bad happened.") (intl:gettext "Could not restore ~S to its original contents: ~A") filename (unix:get-unix-error-msg err)))))) ;;; DELETE-ORIGINAL -- internal ;;; ;;; Delete a backup file. Used during CLOSE. ;;; (defun delete-original (filename original) (declare (type simple-base-string filename) (type (or simple-base-string null) original)) (when original (multiple-value-bind (okay err) (unix:unix-unlink original) (unless okay (cerror "Go on as if nothing bad happened." "Could not delete ~S during close of ~S: ~A" original filename (unix:get-unix-error-msg err)))))) ;;; FD-STREAM-MISC-ROUTINE -- input ;;; ;;; Handle the various misc operations on fd-stream. ;;; (defun fd-stream-misc-routine (stream operation &optional arg1 arg2) (declare (ignore arg2)) (case operation (:listen (or (not (eql (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream))) (fd-stream-listen stream) (setf (fd-stream-listen stream) (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set))) (unix:fd-zero read-fds) (unix:fd-set (fd-stream-fd stream) read-fds) (unix:unix-fast-select (1+ (fd-stream-fd stream)) (alien:addr read-fds) nil nil 0 0)) 1)))) (:unread #-unicode (setf (fd-stream-unread stream) arg1) #+unicode (cond ((lisp-stream-string-buffer stream) (if (zerop (lisp-stream-string-index stream)) (setf (fd-stream-unread stream) arg1) (decf (lisp-stream-string-index stream)))) (t (if (zerop (fd-stream-last-char-read-size stream)) (setf (fd-stream-unread stream) arg1) (decf (fd-stream-ibuf-head stream) (fd-stream-last-char-read-size stream))))) ;; Paul says: ;; ;; Not needed for unicode when unreading is implemented by backing up in ;; the buffer (e.g., with last-char-read-size...) ;; ;; (AFAICS there's nothing wrong with setting it there, but it ;; screws up read-interactive in my toplevel command thing - ;; leaves it expecting to read arguments when it shouldn't, ;; because LISTEN returns T when there's no input pending, but I ;; don't understand why...) #-unicode (setf (fd-stream-listen stream) t)) (:close (cond (arg1 ;; We got us an abort on our hands. (when (fd-stream-handler stream) (system:remove-fd-handler (fd-stream-handler stream)) (setf (fd-stream-handler stream) nil)) (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream)) (revert-file (fd-stream-file stream) (fd-stream-original stream)))) (t #+(and unicode (not unicode-bootstrap)) (when (and (output-stream-p stream) (eq (stream-element-type stream) 'character)) ;; For output character streams, we need to flush out ;; any state that the external format might have. #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream)) (funcall (ef-flush (fd-stream-external-format stream)) stream)) (fd-stream-misc-routine stream :finish-output) (when (fd-stream-delete-original stream) (delete-original (fd-stream-file stream) (fd-stream-original stream))))) (when (fboundp 'cancel-finalization) (cancel-finalization stream)) (unix:unix-close (fd-stream-fd stream)) (when (fd-stream-obuf-sap stream) (push (fd-stream-obuf-sap stream) *available-buffers*) (setf (fd-stream-obuf-sap stream) nil)) (when (fd-stream-ibuf-sap stream) (push (fd-stream-ibuf-sap stream) *available-buffers*) (setf (fd-stream-ibuf-sap stream) nil)) (lisp::set-closed-flame stream)) (:clear-input (setf (fd-stream-unread stream) nil) ;;@@ #+unicode (setf (fd-stream-last-char-read-size stream) 0) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) (catch 'eof-input-catcher (loop (multiple-value-bind (count errno) (alien:with-alien ((read-fds (alien:struct unix:fd-set))) (unix:fd-zero read-fds) (unix:fd-set (fd-stream-fd stream) read-fds) (unix:unix-fast-select (1+ (fd-stream-fd stream)) (alien:addr read-fds) nil nil 0 0)) (cond ((eql count 1) (do-input stream) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0)) ((and (not count) (eql errno unix:eintr))) (t (return t))))))) (:force-output (flush-output-buffer stream)) (:finish-output (flush-output-buffer stream) (do () ((null (fd-stream-output-later stream))) (system:serve-all-events))) (:element-type (fd-stream-element-type stream)) (:interactive-p (unix:unix-isatty (fd-stream-fd stream))) (:line-length 80) (:charpos (fd-stream-char-pos stream)) (:file-length (unless (fd-stream-file stream) (error 'simple-type-error :datum stream :expected-type 'file-stream :format-control (intl:gettext "~s is not a stream associated with a file.") :format-arguments (list stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (unix:unix-fstat (fd-stream-fd stream)) (declare (ignore ino nlink uid gid rdev atime mtime ctime blksize blocks)) (unless okay (error 'simple-file-error :format-control (intl:gettext "Error fstating ~S: ~A") :format-arguments (list stream (unix:get-unix-error-msg dev)))) (if (zerop mode) nil (values (truncate size (fd-stream-element-size stream)))))) (:file-position (fd-stream-file-position stream arg1)) (:clear-output (setf (fd-stream-obuf-tail stream) 0)))) ;;; FD-STREAM-FILE-POSITION -- internal. ;;; (defun fd-stream-file-position (stream &optional newpos) (declare (type fd-stream stream) (type (or (integer 0) (member nil :start :end)) newpos)) (if (null newpos) (system:without-interrupts ;; First, find the position of the UNIX file descriptor in the file. (multiple-value-bind (posn errno) (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr) (declare (type (or (integer 0) null) posn)) #+nil (format t "lseek returns ~D ~D~%" posn errno) (cond (posn ;; Adjust for buffered output: ;; If there is any output buffered, the *real* file position ;; will be larger than reported by lseek because lseek ;; obviously cannot take into account output we have not ;; sent yet. (dolist (later (fd-stream-output-later stream)) (incf posn (- (the index (caddr later)) (the index (cadr later))))) (incf posn (fd-stream-obuf-tail stream)) ;; Adjust for unread input: ;; If there is any input read from UNIX but not supplied to ;; the user of the stream, the *real* file position will ;; smaller than reported, because we want to look like the ;; unread stuff is still available. (decf posn (- (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) #+nil (format t "Updated posn = ~D~%" posn) #+unicode (when (fd-stream-string-buffer stream) ;; The string buffer contains Lisp characters, ;; not octets! To figure out how many octets ;; have not been already supplied, we need to ;; count how many octets were consumed for all ;; the characters in the string bbuffer that have ;; not been supplied. (let ((ocount (fd-stream-octet-count stream))) (when ocount ;; Note: string-index starts at 1 (because ;; index 0 is for the unread-char), but ;; octet-count doesn't use that. Hence, ;; subtract one from string-index and ;; string-buffer-len. #+nil (progn (format t "~&ocount = ~D~%" ocount) (format t "posn = ~D~%" posn)) (loop for k of-type fixnum from (1- (fd-stream-string-index stream)) below (1- (fd-stream-string-buffer-len stream)) do (decf posn (aref ocount k))) #+nil (progn (format t "new posn = ~D~%" posn) (format t "in-buffer-length = ~D~%" in-buffer-length) (format t "in-length = ~D~%" (fd-stream-in-length stream)) (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream)))))) (when (fd-stream-in-buffer stream) ;; When we have an in-buffer (whether we have a ;; string-buffer or not!), we need to adjust for ;; the octets that have not yet been supplied. ;; (This case happens with string-buffer when the ;; in-buffer does not have enough octets to form a ;; complete character.) If there's no ;; string-buffer and no in-buffer, then the ibuf ;; tail and head pointers contain all the ;; information needed. #+nil (progn (format t "in-buffer-length = ~D~%" in-buffer-length) (format t "in-length = ~D~%" (fd-stream-in-length stream)) (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))) (decf posn (- (fd-stream-in-length stream) (fd-stream-in-index stream)))) #+nil (format t "fd-stream-unread = ~S~%" (fd-stream-unread stream)) (when (fd-stream-unread stream) ;;@@ (decf posn)) ;; Divide bytes by element size. (truncate posn (fd-stream-element-size stream))) ((eq errno unix:espipe) nil) (t (system:with-interrupts (error (intl:gettext "Error lseek'ing ~S: ~A") stream (unix:get-unix-error-msg errno))))))) (let ((offset 0) origin) (declare (type (integer 0) offset)) ;; Make sure we don't have any output pending, because if we move the ;; file pointer before writing this stuff, it will be written in the ;; wrong location. (flush-output-buffer stream) (do () ((null (fd-stream-output-later stream))) (system:serve-all-events)) ;; Clear out any pending input to force the next read to go to the ;; disk. (setf (fd-stream-unread stream) nil) ;;@@ #+unicode (progn (setf (fd-stream-last-char-read-size stream) 0) (setf (fd-stream-string-index stream) (fd-stream-string-buffer-len stream))) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) ;; Trash cached value for listen, so that we check next time. (setf (fd-stream-listen stream) nil) ;; Now move it. (cond ((eq newpos :start) (setf offset 0 origin unix:l_set)) ((eq newpos :end) (setf offset 0 origin unix:l_xtnd)) ((typep newpos '(integer 0)) (setf offset (* newpos (fd-stream-element-size stream)) origin unix:l_set)) (t (error (intl:gettext "Invalid position given to file-position: ~S") newpos))) (multiple-value-bind (posn errno) (unix:unix-lseek (fd-stream-fd stream) offset origin) (cond (posn t) ((eq errno unix:espipe) nil) (t (error (intl:gettext "Error lseek'ing ~S: ~A") stream (unix:get-unix-error-msg errno)))))))) ;;;; Creation routines (MAKE-FD-STREAM and OPEN) ;; The unicode version of this is in fd-stream-extfmt.lisp #-(and unicode (not unicode-boootstrap)) (defun %set-fd-stream-external-format (stream extfmt &optional (updatep t)) (declare (ignore stream extfmt updatep)) (values)) ;;; MAKE-FD-STREAM -- Public. ;;; ;;; Returns a FD-STREAM on the given file. ;;; (defun make-fd-stream (fd &key (input nil input-p) (output nil output-p) (element-type 'base-char) (buffering :full) timeout file original delete-original pathname input-buffer-p ;; DO NOT translate these! It causes an ;; infinite loop. We need to open a file for ;; the translations, but if you translate ;; these, then we need to do a lookup which ;; wants to open the mo file which calls this ;; to name which causes a lookup .... (name (if file (format nil "file ~S" file) (format nil "descriptor ~D" fd))) auto-close (external-format :default) binary-stream-p decoding-error encoding-error) (declare (type index fd) (type (or index null) timeout) (type (member :none :line :full) buffering)) "Create a stream for the given unix file descriptor. If input is non-nil, allow input operations. If output is non-nil, allow output operations. If neither input nor output are specified, default to allowing input. Element-type indicates the element type to use (as for open). Buffering indicates the kind of buffering to use. Timeout (if true) is the number of seconds to wait for input. If NIL (the default), then wait forever. When we time out, we signal IO-TIMEOUT. File is the name of the file (will be returned by PATHNAME). Name is used to identify the stream when printed. External-format is the external format to use for the stream. Decoding-error and Encoding-error indicate how decoding/encoding errors on the stream should be handled. The default is to use a replacement character." (cond ((not (or input-p output-p)) (setf input t)) ((not (or input output)) (error (intl:gettext "File descriptor must be opened either for input or output.")))) (let ((stream (if binary-stream-p (%make-binary-text-stream :fd fd :name name :file file :original original :delete-original delete-original :pathname pathname :buffering buffering :timeout timeout) (let ((e (cond ((characterp encoding-error) (constantly (char-code encoding-error))) (t encoding-error))) (d (cond ((characterp decoding-error) (constantly (char-code decoding-error))) ((eq t decoding-error) #'(lambda (&rest args) (apply 'cerror #+unicode _"Use Unicode replacement character instead" #-unicode _"Use question mark character instead" args) #+unicode stream:+replacement-character-code+ #-unicode #\?)) (t decoding-error)))) (%make-fd-stream :fd fd :name name :file file :original original :delete-original delete-original :pathname pathname :buffering buffering :timeout timeout :char-to-octets-error e :octets-to-char-error d))))) ;; Set the lisp-stream flags appropriately for the kind of stream ;; we have (character, binary, binary-text-stream). (cond ((typep stream 'binary-text-stream) (setf (fd-stream-flags stream) #b100)) ((subtypep element-type 'character) (setf (fd-stream-flags stream) #b001)) (t (setf (fd-stream-flags stream) #b010))) ;; FIXME: setting the external format here should be better ;; integrated into set-routines. We do it before so that ;; set-routines can create an in-buffer if appropriate. But we ;; need to do it after to put the correct input routines for the ;; external format. ;; ;;#-unicode-bootstrap ; fails in stream-reinit otherwise (%set-fd-stream-external-format stream external-format nil) (set-routines stream element-type input output input-buffer-p :binary-stream-p binary-stream-p) (%set-fd-stream-external-format stream external-format nil) (when (and auto-close (fboundp 'finalize)) (finalize stream #'(lambda () (unix:unix-close fd) (format *terminal-io* (intl:gettext "** Closed ~A~%") name) (when original (revert-file file original))))) stream)) ;;; PICK-BACKUP-NAME -- internal ;;; ;;; Pick a name to use for the backup file. ;;; (defvar *backup-extension* ".BAK" "This is a string that OPEN tacks on the end of a file namestring to produce a name for the :if-exists :rename-and-delete and :rename options. Also, this can be a function that takes a namestring and returns a complete namestring.") ;;; (defun pick-backup-name (name) (declare (type simple-string name)) (let ((ext *backup-extension*)) (etypecase ext (simple-string (concatenate 'simple-string name ext)) (function (funcall ext name))))) ;;; NEXT-VERSION -- internal ;;; ;;; Find the next available versioned name for a file. ;;; (defun next-version (name) (declare (type simple-string name)) (let* ((*ignore-wildcards* t) (sep (position #\/ name :from-end t)) (base (if sep (subseq name 0 (1+ sep)) "")) (dir (unix:open-dir base))) (multiple-value-bind (name type version) (extract-name-type-and-version name (if sep (1+ sep) 0) (length name)) (let ((version (if (symbolp version) 1 (1+ version))) (match (if type (concatenate 'string name "." type ".~") (concatenate 'string name ".~")))) (when dir (unwind-protect (loop (let ((name (unix:read-dir dir))) (cond ((null name) (return)) ((and (> (length name) (length match)) (string= name match :end1 (length match))) (multiple-value-bind (v e) (parse-integer name :start (length match) :junk-allowed t) (when (and v (= (length name) (1+ e)) (char= (schar name e) #\~)) (setq version (max version (1+ v))))))))) (unix:close-dir dir))) (concatenate 'string base match (quick-integer-to-string version) "~"))))) ;;; ASSURE-ONE-OF -- internal ;;; ;;; Assure that the given arg is one of the given list of valid things. ;;; Allow the user to fix any problems. ;;; (defun assure-one-of (item list what) (unless (member item list) (loop (cerror (intl:gettext "Enter new value for ~*~S") (intl:gettext "~S is invalid for ~S. Must be one of~{ ~S~}") item what list) (format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what) (force-output *query-io*) (setf item (read *query-io*)) (when (member item list) (return)))) item) ;;; DO-OLD-RENAME -- Internal ;;; ;;; Rename Namestring to Original. First, check if we have write access, ;;; since we don't want to trash unwritable files even if we technically can. ;;; We return true if we succeed in renaming. ;;; (defun do-old-rename (namestring original) (unless (unix:unix-access namestring unix:w_ok) (cerror (intl:gettext "Try to rename it anyway.") (intl:gettext "File ~S is not writable.") namestring)) (multiple-value-bind (okay err) (unix:unix-rename namestring original) (cond (okay t) (t (cerror (intl:gettext "Use :SUPERSEDE instead.") (intl:gettext "Could not rename ~S to ~S: ~A.") namestring original (unix:get-unix-error-msg err)) nil)))) ;;; FD-OPEN -- Internal ;;; ;;; Open a file. ;;; (defun fd-open (pathname direction if-exists if-exists-given if-does-not-exist if-does-not-exist-given) (declare (type pathname pathname) (type (member :input :output :io :probe) direction) (type (member :error :new-version :rename :rename-and-delete :overwrite :append :supersede nil) if-exists) (type (member :error :create nil) if-does-not-exist)) (multiple-value-bind (input output mask) (ecase direction (:input (values t nil unix:o_rdonly)) (:output (values nil t unix:o_wronly)) (:io (values t t unix:o_rdwr)) (:probe (values t nil unix:o_rdonly))) (declare (type index mask)) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given (setf if-exists (if (eq (pathname-version pathname) :newest) :new-version :error))) (case if-exists ((:error nil) (setf mask (logior mask unix:o_excl))) ((:new-version :rename :rename-and-delete) (setf mask (logior mask unix:o_creat))) (:supersede (setf mask (logior mask unix:o_trunc))))) (t (setf if-exists nil))) ; :ignore-this-arg (unless if-does-not-exist-given (setf if-does-not-exist (cond ((eq direction :input) :error) ((and output (member if-exists '(:overwrite :append))) :error) ((eq direction :probe) nil) (t :create)))) (if (eq if-does-not-exist :create) (setf mask (logior mask unix:o_creat))) (let ((name (cond ((unix-namestring pathname input)) ((and input (eq if-does-not-exist :create)) (unix-namestring pathname nil))))) (let ((original (cond ((and name (eq if-exists :new-version)) (next-version name)) ((member if-exists '(:rename :rename-and-delete)) (pick-backup-name name)))) (delete-original (eq if-exists :rename-and-delete)) (mode #o666)) (when original ;; We are doing a :rename or :rename-and-delete. ;; Determine if the file already exists, make sure the original ;; file is not a directory and keep the mode (let ((exists (and name (multiple-value-bind (okay err/dev inode orig-mode) (unix:unix-stat name) (declare (ignore inode) (type (or index null) orig-mode)) (cond (okay (when (and output (= (logand orig-mode #o170000) #o40000)) (error 'simple-file-error :pathname pathname :format-control (intl:gettext "Cannot open ~S for output: Is a directory.") :format-arguments (list name))) (setf mode (logand orig-mode #o777)) t) ((eql err/dev unix:enoent) nil) (t (error 'simple-file-error :pathname pathname :format-control (intl:gettext "Cannot find ~S: ~A") :format-arguments (list name (unix:get-unix-error-msg err/dev))))))))) (unless (and exists (do-old-rename name original)) (setf original nil) (setf delete-original nil) ;; In order to use SUPERSEDE instead, we have ;; to make sure unix:o_creat corresponds to ;; if-does-not-exist. unix:o_creat was set ;; before because of if-exists being :rename. (unless (eq if-does-not-exist :create) (setf mask (logior (logandc2 mask unix:o_creat) unix:o_trunc))) (setf if-exists :supersede)))) ;; Okay, now we can try the actual open. (loop (multiple-value-bind (fd errno) (if name (unix:unix-open name mask mode) (values nil unix:enoent)) (cond ((fixnump fd) (when (eq if-exists :append) (unix:unix-lseek fd 0 unix:l_xtnd)) ; SEEK_END (return (values fd name original delete-original))) ((eql errno unix:enoent) (case if-does-not-exist (:error (cerror (intl:gettext "Return NIL.") 'simple-file-error :pathname pathname :format-control (intl:gettext "Error opening ~S, ~A.") :format-arguments (list pathname (unix:get-unix-error-msg errno)))) (:create (cerror (intl:gettext "Return NIL.") 'simple-file-error :pathname pathname :format-control (intl:gettext "Error creating ~S, path does not exist.") :format-arguments (list pathname)))) (return nil)) ((eql errno unix:eexist) (unless (eq nil if-exists) (cerror (intl:gettext "Return NIL.") 'simple-file-error :pathname pathname :format-control (intl:gettext "Error opening ~S, ~A.") :format-arguments (list pathname (unix:get-unix-error-msg errno)))) (return nil)) ((eql errno unix:eacces) (cerror (intl:gettext "Try again.") 'simple-file-error :pathname pathname :format-control (intl:gettext "Error opening ~S, ~A.") :format-arguments (list pathname (unix:get-unix-error-msg errno)))) (t (cerror (intl:gettext "Return NIL.") 'simple-file-error :pathname pathname :format-control (intl:gettext "Error opening ~S, ~A.") :format-arguments (list pathname (unix:get-unix-error-msg errno))) (return nil))))))))) ;;; OPEN-FD-STREAM -- Internal ;;; ;;; Open an fd-stream connected to a file. ;;; (defun open-fd-stream (pathname &key (direction :input) (element-type 'base-char) (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given) (external-format :default) class decoding-error encoding-error) (declare (type pathname pathname) (type (member :input :output :io :probe) direction) (type (member :error :new-version :rename :rename-and-delete :overwrite :append :supersede nil) if-exists) (type (member :error :create nil) if-does-not-exist)) (multiple-value-bind (fd namestring original delete-original) (fd-open pathname direction if-exists if-exists-given if-does-not-exist if-does-not-exist-given) (when fd (case direction ((:input :output :io) ;; We use the :class option to tell us if we want a ;; binary-text stream or not. (make-fd-stream fd :input (member direction '(:input :io)) :output (member direction '(:output :io)) :element-type element-type :file namestring :original original :delete-original delete-original :pathname pathname :input-buffer-p t :auto-close t :external-format external-format :binary-stream-p class :decoding-error decoding-error :encoding-error encoding-error)) (:probe (let ((stream (%make-fd-stream :name namestring :fd fd :pathname pathname :element-type element-type))) (close stream) stream)))))) ;;; OPEN -- public ;;; ;;; Open the given file. ;;; (defun open (filename &rest options &key (direction :input) (element-type 'base-char element-type-given) (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given) (external-format :default) class mapped input-handle output-handle decoding-error encoding-error &allow-other-keys &aux ; Squelch assignment warning. (options options) (direction direction) (if-does-not-exist if-does-not-exist) (if-exists if-exists)) "Return a stream which reads from or writes to Filename. Defined keywords: :direction - one of :input, :output, :io, or :probe :element-type - Type of object to read or write, default BASE-CHAR :if-exists - one of :error, :new-version, :rename, :rename-and-delete, :overwrite, :append, :supersede or nil :if-does-not-exist - one of :error, :create or nil :external-format - an external format name :decoding-error - How to handle decoding errors from the external format. If a character, then that character is used as the replacment character for all errors. If T, then a continuable error is signaled. If continued, the Unicode replacement character is used. Otherwise, it should be a symbol or function of 3 arguments. If it returns, it should return a code point to use as the replacment. The function arguments are a format message string, the offending octet, and the number of octets read in the current encoding. :encoding-error - Like :decoding-error, but for errors when encoding the stream. If a character, that character is used as the replacment code point. Otherwise, it should be a symbol or function oof two arguments: a format message string and the incorrect codepoint. See the manual for details." (declare (ignore element-type external-format input-handle output-handle decoding-error encoding-error)) ;; OPEN signals a file-error if the filename is wild. (when (wild-pathname-p filename) (error 'file-error :pathname filename)) ;; First, make sure that DIRECTION is valid. Allow it to be changed if not. (setq direction (assure-one-of direction '(:input :output :io :probe) :direction)) (setf (getf options :direction) direction) (when (and if-exists-given (member direction '(:output :io))) (setq if-exists (assure-one-of if-exists '(:error :new-version :rename :rename-and-delete :overwrite :append :supersede nil) :if-exists)) (setf (getf options :if-exists) if-exists)) (when if-does-not-exist-given (setq if-does-not-exist (assure-one-of if-does-not-exist '(:error :create nil) :if-does-not-exist)) (setf (getf options :if-does-not-exist) if-does-not-exist)) (let ((filespec (merge-pathnames filename)) (options (copy-list options)) (class (or class 'fd-stream))) (cond ((eq class 'fd-stream) (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) (apply #'open-fd-stream filespec options)) ((eq class 'binary-text-stream) ;; Like fd-stream, but binary and text allowed. This is ;; indicated by leaving the :class option around for ;; open-fd-stream to see. (remf options :mapped) (remf options :input-handle) (remf options :output-handle) (apply #'open-fd-stream filespec options)) ((subtypep class 'stream:simple-stream) (when element-type-given (cerror (intl:gettext "Do it anyway.") (intl:gettext "Can't create simple-streams with an element-type."))) (when (and (eq class 'stream:file-simple-stream) mapped) (setq class 'stream:mapped-file-simple-stream) (setf (getf options :class) 'stream:mapped-file-simple-stream)) (when (subtypep class 'stream:file-simple-stream) (when (eq direction :probe) (setq class 'stream:probe-simple-stream))) (apply #'make-instance class :filename filespec options)) ((subtypep class 'ext:fundamental-stream) (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) (let ((stream (apply #'open-fd-stream filespec options))) (when stream (make-instance class :lisp-stream stream)))) (t (error (intl:gettext "Unable to open streams of class ~S.") class))))) ;;;; Initialization. (defvar *tty* nil "The stream connected to the controlling terminal or NIL if there is none.") (defvar *stdin* nil "The stream connected to the standard input (file descriptor 0).") (defvar *stdout* nil "The stream connected to the standard output (file descriptor 1).") (defvar *stderr* nil "The stream connected to the standard error output (file descriptor 2).") ;;; STREAM-INIT -- internal interface ;;; ;;; Called when the cold load is first started up. ;;; (defun stream-init () (stream-reinit) (setf *terminal-io* (make-synonym-stream '*tty*)) (setf *standard-output* (make-synonym-stream '*stdout*)) (setf *standard-input* (make-two-way-stream (make-synonym-stream '*stdin*) *standard-output*)) (setf *error-output* (make-synonym-stream '*stderr*)) (setf *query-io* (make-synonym-stream '*terminal-io*)) (setf *debug-io* *query-io*) (setf *trace-output* *standard-output*) nil) ;;; STREAM-REINIT -- internal interface ;;; ;;; Called whenever a saved core is restarted. ;;; (defun stream-reinit () (setf *available-buffers* nil) (setf *stdin* (make-fd-stream 0 :name "Standard Input" :input t :buffering :line :external-format :iso8859-1)) (setf *stdout* (make-fd-stream 1 :name "Standard Output" :output t :buffering :line :external-format :iso8859-1)) (setf *stderr* (make-fd-stream 2 :name "Standard Error" :output t :buffering :line :external-format :iso8859-1)) (let ((tty (and (not *batch-mode*) (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))) (setf *tty* (if tty (make-fd-stream tty :name "the Terminal" :input t :output t :buffering :line :auto-close t :external-format :iso8859-1) (make-two-way-stream *stdin* *stdout*)))) nil) ;;;; Beeping. (defun default-beep-function (stream) (write-char #\bell stream) (finish-output stream)) (defvar *beep-function* #'default-beep-function "This is called in BEEP to feep the user. It takes a stream.") (defun beep (&optional (stream *terminal-io*)) (funcall *beep-function* stream)) ;;; File-Name -- internal interface ;;; ;;; Kind of like File-Position, but is an internal hack used by the filesys ;;; stuff to get and set the file name. ;;; (defun file-name (stream &optional new-name) (typecase stream (stream:simple-stream (if new-name (stream::%file-rename stream new-name) (stream::%file-name stream))) (fd-stream (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) (unix-namestring new-name nil)) t) (t (fd-stream-pathname stream)))))) #+unicode (stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+) ;; While it would be nice not to have to call CHAR-TO-OCTETS to ;; figure out the length when the external format has fixed size ;; outputs, we can't. For example, utf16 will output a BOM, which ;; wouldn't be reflected in the count if we don't call ;; CHAR-TO-OCTETS. `(lambda (stream object &aux (count 0)) (declare (type fd-stream stream) (type (or character string) object) (type (and fixnum unsigned-byte) count) #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#) (labels ((efstate (state) (stream::copy-state ,extfmt state)) (eflen (char) (stream::char-to-octets ,extfmt char (fd-stream-co-state stream) (lambda (byte) (declare (ignore byte)) (incf count)) (fd-stream-char-to-octets-erroor stream)))) (let* ((co-state (fd-stream-co-state stream)) (old-ef-state (efstate (cdr (fd-stream-co-state stream)))) (old-state (cons (car co-state) old-ef-state))) (etypecase object (character (eflen object)) (string (dovector (ch object) (eflen ch)))) ;; Restore state (setf (fd-stream-co-state stream) old-state) count)))) (defun file-string-length (stream object) (declare (type (or string character) object) (type (or file-stream broadcast-stream stream:simple-stream) stream)) "Return the delta in Stream's FILE-POSITION that would be caused by writing Object to Stream. Non-trivial only in implementations that support international character sets." (typecase stream (stream:simple-stream (stream::%file-string-length stream object)) (broadcast-stream ;; CLHS says we must return 1 in this case 1) #+unicode (t (funcall (ef-strlen (fd-stream-external-format stream)) stream object)) #-unicode (t (etypecase object (character 1) (string (length object)))))) #+unicode (stream::def-ef-macro ef-copy-state (extfmt lisp stream::+ef-max+ stream::+ef-copy-state+) ;; Return a copy of the state of an external format. `(lambda (state) (declare (ignorable state)) (stream::copy-state ,extfmt state))) cmucl-21a/src/code/fdefinition.lisp000066400000000000000000000176521260377556400174640ustar00rootroot00000000000000;;; -*- Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/fdefinition.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions that hack on the global function namespace (primarily ;;; concerned with SETF functions here). Also, function encapsulation ;;; and routines that set and return definitions disregarding whether ;;; they might be encapsulated. ;;; ;;; Written by Rob MacLachlan ;;; Modified by Bill Chiles (wrote encapsulation stuff) ;;; Modified more by William Lott (added ``fdefn'' objects) ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(encapsulate unencapsulate encapsulated-p basic-definition argument-list *setf-fdefinition-hook* define-function-name-syntax valid-function-name-p)) (in-package "KERNEL") (export '(fdefn make-fdefn fdefn-p fdefn-name fdefn-function fdefn-makunbound fdefn-or-lose %coerce-to-function raw-definition)) (in-package "LISP") (export '(fdefinition fboundp fmakunbound)) ;;;; Function names. (defvar *valid-function-names* ()) (defun %define-function-name-syntax (name syntax-checker) (let ((found (assoc name *valid-function-names* :test #'eq))) (if found (setf (cdr found) syntax-checker) (setq *valid-function-names* (acons name syntax-checker *valid-function-names*))))) (defmacro define-function-name-syntax (name (var) &body body) "Define (NAME ...) to be a valid function name whose syntax is checked by BODY. In BODY, VAR is bound to an actual function name of the form (NAME ...) to check. BODY should return two values. First value true means the function name is valid. Second value is the name, a symbol, of the function for use in the BLOCK of DEFUNs and in similar situations." (let ((syntax-checker (symbolicate '%check- name '-function-name))) `(progn (defun ,syntax-checker (,var) ,@body) (%define-function-name-syntax ',name #',syntax-checker)))) (defun valid-function-name-p (name) "First value is true if NAME has valid function name syntax. Second value is the name, a symbol, to use as a block name in DEFUNs and in similar situations." (typecase name (cons (cond ((and (symbolp (car name)) (consp (cdr name))) (let ((syntax-checker (cdr (assoc (car name) *valid-function-names* :test #'eq)))) (if syntax-checker (funcall syntax-checker name) (values nil name)))) (t (values nil name)))) (symbol (values t name)) (otherwise (values nil name)))) (define-function-name-syntax setf (name) (destructuring-bind (setf fn &rest rest) name (declare (ignore setf)) (if rest (values nil name) (typecase fn (symbol (values t fn)) (cons (cond ((eq 'setf (car fn)) (values nil fn)) (t (valid-function-name-p fn)))) (otherwise (values nil fn)))))) (define-function-name-syntax :macro (name) (when (eql 2 (length name)) (valid-function-name-p (second name)))) (define-function-name-syntax :compiler-macro (name) (when (eql 2 (length name)) (valid-function-name-p (second name)))) (define-function-name-syntax flet (name) (valid-function-name-p (cadr name))) (define-function-name-syntax labels (name) (valid-function-name-p (cadr name))) ;;;; Fdefinition (fdefn) objects. (defun make-fdefn (name) (make-fdefn name)) (defun fdefn-name (fdefn) (declare (type fdefn fdefn)) (fdefn-name fdefn)) (defun fdefn-function (fdefn) (declare (type fdefn fdefn) (values (or function null))) (fdefn-function fdefn)) (defun (setf fdefn-function) (fun fdefn) (declare (type function fun) (type fdefn fdefn) (values function)) (setf (fdefn-function fdefn) fun)) (defun fdefn-makunbound (fdefn) (declare (type fdefn fdefn)) (fdefn-makunbound fdefn)) ;;; FDEFN-INIT -- internal interface. ;;; ;;; This function is called by %INITIAL-FUNCTION after the globaldb has been ;;; initialized, but before anything else. We need to install these fdefn ;;; objects into the globaldb *before* any top level forms run, or we will ;;; end up with two different fdefn objects being used for the same function ;;; name. *INITIAL-FDEFN-OBJECTS* is set up by GENESIS. ;;; (defvar *initial-fdefn-objects*) (defun fdefn-init () (setq *valid-function-names* nil) (dolist (fdefn *initial-fdefn-objects*) (setf (info function definition (fdefn-name fdefn)) fdefn)) (makunbound '*initial-fdefn-objects*)) ;;; FDEFINITION-OBJECT -- internal interface. ;;; (defun fdefinition-object (name create) "Return the fdefn object for NAME. If it doesn't already exist and CREATE is non-NIL, create a new (unbound) one." (declare (values (or fdefn null))) (multiple-value-bind (valid-name-p fname) (valid-function-name-p name) (unless valid-name-p (error 'simple-type-error :datum fname :expected-type '(satisfies valid-function-name-p) :format-control (intl:gettext "Invalid function name: ~S") :format-arguments (list name)))) (let ((fdefn (info function definition name))) (if (and (null fdefn) create) (setf (info function definition name) (make-fdefn name)) fdefn))) (declaim (inline fdefn-or-lose)) (defun fdefn-or-lose (name) "Return the FDEFN of NAME. Signal an error if there is none or if it's function is null." (let ((fdefn (fdefinition-object name nil))) (unless (and fdefn (fdefn-function fdefn)) (error 'undefined-function :name name)) fdefn)) ;;; %COERCE-TO-FUNCTION -- public. ;;; ;;; The compiler emits calls to this when someone tries to funcall a symbol. ;;; (defun %coerce-to-function (name) "Returns the definition for name, including any encapsulations. Settable with SETF." (fdefn-function (fdefn-or-lose name))) ;;; RAW-DEFINITION -- public. ;;; ;;; Just another name for %coerce-to-function. ;;; (declaim (inline raw-definition)) (defun raw-definition (name) (declare (optimize (inhibit-warnings 3))) ;; We know that we are calling %coerce-to-function, so don't tell us about ;; it. (%coerce-to-function name)) (defun (setf raw-definition) (function name) (let ((fdefn (fdefinition-object name t))) (setf (fdefn-function fdefn) function))) ;;;; FDEFINITION. (defun fdefinition (function-name) "Return FUNCTION-NAME's global function definition. If FUNCTION-NAME is fwrapped, return the primary function definition stored in the innermost fwrapper." (let* ((fdefn (fdefn-or-lose function-name)) (last (fwrappers:last-fwrapper fdefn))) (if last (fwrappers:fwrapper-next last) (fdefn-function fdefn)))) (defvar *setf-fdefinition-hook* nil "This holds functions that (SETF FDEFINITION) invokes before storing the new value. These functions take the function name and the new value.") (defun %set-fdefinition (function-name new-value) "Set FUNCTION-NAME's global function definition to NEW-VALUE. If FUNCTION-NAME is fwrapped, set the primary function stored in the innermost fwrapper." (declare (type function new-value) (optimize (safety 1))) (let ((fdefn (fdefinition-object function-name t))) (when (boundp '*setf-fdefinition-hook*) (dolist (f *setf-fdefinition-hook*) (funcall f function-name new-value))) (let ((last (fwrappers:last-fwrapper fdefn))) (if last (setf (fwrappers:fwrapper-next last) new-value) (setf (fdefn-function fdefn) new-value))))) (defsetf fdefinition %set-fdefinition) ;;;; FBOUNDP and FMAKUNBOUND. (defun fboundp (name) "Return true if name has a global function definition." (let ((fdefn (fdefinition-object name nil))) (and fdefn (fdefn-function fdefn) t))) (defun fmakunbound (name) "Make Name have no global function definition." (let ((fdefn (fdefinition-object name nil))) (when fdefn (fdefn-makunbound fdefn))) (kernel:undefine-function-name name) name) cmucl-21a/src/code/filesys.lisp000066400000000000000000001430361260377556400166400ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/code/filesys.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; File system interface functions. This file is pretty UNIX specific. ;;; ;;; Written by William Lott ;;; ;;; ********************************************************************** (in-package "LISP") (intl:textdomain "cmucl") (export '(truename probe-file user-homedir-pathname directory rename-file delete-file file-write-date file-author)) (use-package "EXTENSIONS") (in-package "EXTENSIONS") (export '(print-directory complete-file ambiguous-files default-directory purge-backup-files file-writable unix-namestring)) (in-package "LISP") ;;;; Unix pathname host support. ;;; Unix namestrings have the following format: ;;; ;;; namestring := [ directory ] [ file [ type [ version ]]] ;;; directory := [ "/" | search-list ] { file "/" }* ;;; search-list := [^:/]*: ;;; file := [^/]* ;;; type := "." [^/.]* ;;; version := ".*" | ".~" ([1-9]+[0-9]* | "*") "~" ;;; ;;; Note: this grammar is ambiguous. The string foo.bar.~5~ can be parsed ;;; as either just the file specified or as specifying the file, type, and ;;; version. Therefore, we use the following rules when confronted with ;;; an ambiguous file.type.version string: ;;; ;;; - If the first character is a dot, it's part of the file. It is not ;;; considered a dot in the following rules. ;;; ;;; - If there is only one dot, it separates the file and the type. ;;; ;;; - If there are multiple dots and the stuff following the last dot ;;; is a valid version, then that is the version and the stuff between ;;; the second to last dot and the last dot is the type. ;;; ;;; Wildcard characters: ;;; ;;; If the directory, file, type components contain any of the following ;;; characters, it is considered part of a wildcard pattern and has the ;;; following meaning. ;;; ;;; ? - matches any character ;;; * - matches any zero or more characters. ;;; [abc] - matches any of a, b, or c. ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn. ;;; ;;; Any of these special characters can be preceded by a backslash to ;;; cause it to be treated as a regular character. ;;; (defun remove-backslashes (namestr start end) "Remove any occurrences of \\ from the string because we've already checked for whatever may have been backslashed." (declare (type simple-base-string namestr) (type index start end)) (let* ((result (make-string (- end start))) (dst 0) (quoted nil)) (do ((src start (1+ src))) ((= src end)) (cond (quoted (setf (schar result dst) (schar namestr src)) (setf quoted nil) (incf dst)) (t (let ((char (schar namestr src))) (cond ((char= char #\\) (setq quoted t)) (t (setf (schar result dst) char) (incf dst))))))) (when quoted (error 'namestring-parse-error :complaint (intl:gettext "Backslash in bad place.") :namestring namestr :offset (1- end))) (shrink-vector result dst))) (defvar *ignore-wildcards* nil "If non-NIL, Unix shell-style wildcards are ignored when parsing pathname namestrings. They are also ignored when computing namestrings for pathname objects. Thus, *, ?, etc. are not wildcards when parsing a namestring, and are not escaped when printing pathnames.") (defun maybe-make-pattern (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (if *ignore-wildcards* (subseq namestr start end) (collect ((pattern)) (let ((quoted nil) (any-quotes nil) (last-regular-char nil) (index start)) (flet ((flush-pending-regulars () (when last-regular-char (pattern (if any-quotes (remove-backslashes namestr last-regular-char index) (subseq namestr last-regular-char index))) (setf any-quotes nil) (setf last-regular-char nil)))) (loop (when (>= index end) (return)) (let ((char (schar namestr index))) (cond (quoted (incf index) (setf quoted nil)) ((char= char #\\) (setf quoted t) (setf any-quotes t) (unless last-regular-char (setf last-regular-char index)) (incf index)) ((char= char #\?) (flush-pending-regulars) (pattern :single-char-wild) (incf index)) ((char= char #\*) (flush-pending-regulars) (pattern :multi-char-wild) (incf index)) ((char= char #\[) (flush-pending-regulars) (let ((close-bracket (position #\] namestr :start index :end end))) (unless close-bracket (error 'namestring-parse-error :complaint (intl:gettext "``['' with no corresponding ``]''") :namestring namestr :offset index)) (pattern (list :character-set (subseq namestr (1+ index) close-bracket))) (setf index (1+ close-bracket)))) (t (unless last-regular-char (setf last-regular-char index)) (incf index))))) (flush-pending-regulars))) (cond ((null (pattern)) "") ((null (cdr (pattern))) (let ((piece (first (pattern)))) (typecase piece ((member :multi-char-wild) :wild) (simple-string piece) (t (make-pattern (pattern)))))) (t (make-pattern (pattern))))))) ;;; extract-name-type-and-version -- Internal. ;;; (defun extract-name-type-and-version (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (labels ((explicit-version (namestr start end) ;; Look for something like "~*~" at the end of the ;; namestring, where * can be #\* or some digits. This ;; denotes a version. ;;(format t "explicit-version ~S ~A ~A~%" namestr start end) (cond ((or (< (- end start) 4) (and (char/= (schar namestr (1- end)) #\~) (char/= (schar namestr (1- end)) #\*))) ;; No explicit version given, so return NIL to ;; indicate we don't want file versions, unless ;; requested in other ways. ;;(format t "case 1: ~A ~A~%" nil end) (values nil end)) ((and (not *ignore-wildcards*) (char= (schar namestr (- end 2)) #\*) (char= (schar namestr (- end 3)) #\~) (char= (schar namestr (- end 4)) #\.)) ;; Found "~*~", so it's a wild version ;;(format t "case 2: ~A ~A~%" :wild (- end 4)) (values :wild (- end 4))) (t ;; Look for a version number. Start at the end, just ;; before the ~ and keep looking for digits. If the ;; first non-digit is ~, and the leading character is ;; a non-zero digit, we have a version number, so get ;; it. If not, we didn't find a version number, so we ;; call it :newest (do ((i (- end 2) (1- i))) ((< i (+ start 1)) ;;(format t "case 3: ~A ~A~%" :newest end) (values :newest end)) (let ((char (schar namestr i))) (when (eql char #\~) (return (if (char= (schar namestr (1- i)) #\.) (if (char= (schar namestr (1+ i)) #\0) (values nil end) (values (parse-integer namestr :start (1+ i) :end (1- end)) (1- i))) (values :newest end)))) (unless (char<= #\0 char #\9) ;; It's not a digit. Give up, and say the ;; version is NIL. ;;(format t "case 3 return: ~A ~A~%" nil end) (return (values nil end)))))))) (any-version (namestr start end) ;; process end of string looking for a version candidate. (multiple-value-bind (version where) (explicit-version namestr start end) (cond ((not (eq version :newest)) (values version where)) ((and (not *ignore-wildcards*) (>= (- end 2) start) (char= (schar namestr (- end 1)) #\*) (char= (schar namestr (- end 2)) #\.) (find #\. namestr :start (min (1+ start) (- end 2)) :end (- end 2))) (values :wild (- end 2))) (t (values version where))))) (any-type (namestr start end) ;; Process end of string looking for a type. A leading "." ;; is part of the name. (let ((where (position #\. namestr :start (min (1+ start) end) :end end :from-end t))) (when where (values where end)))) (any-name (namestr start end) (declare (ignore namestr)) (values start end))) (multiple-value-bind (version vstart) (any-version namestr start end) (multiple-value-bind (tstart tend) (any-type namestr start vstart) (multiple-value-bind (nstart nend) (any-name namestr start (or tstart vstart)) (values (maybe-make-pattern namestr nstart nend) (and tstart (maybe-make-pattern namestr (1+ tstart) tend)) version)))))) ;;; Take a string and return a list of cons cells that mark the char ;;; separated subseq. The first value t if absolute directories location. ;;; (defun split-at-slashes (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (let ((absolute (and (/= start end) (char= (schar namestr start) #\/)))) (when absolute (incf start)) ;; Next, split the remainder into slash separated chunks. (collect ((pieces)) (loop (let ((slash (position #\/ namestr :start start :end end))) (pieces (cons start (or slash end))) (unless slash (return)) (setf start (1+ slash)))) (values absolute (pieces))))) (defun maybe-extract-search-list (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (let ((quoted nil)) (do ((index start (1+ index))) ((= index end) (values nil start)) (if quoted (setf quoted nil) (case (schar namestr index) (#\\ (setf quoted t)) (#\: (return (values (remove-backslashes namestr start index) (1+ index))))))))) (defun parse-unix-namestring (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) (let ((search-list (if absolute nil (let ((first (car pieces))) (multiple-value-bind (search-list new-start) (maybe-extract-search-list namestr (car first) (cdr first)) (when search-list ;; Lose if this search-list is already defined as ;; a logical host. Since the syntax for ;; search-lists and logical pathnames are the ;; same, we can't allow the creation of one when ;; the other is defined. (when (find-logical-host search-list nil) (error (intl:gettext "~A already names a logical host") search-list)) (setf absolute t) (setf (car first) new-start)) search-list))))) (multiple-value-bind (name type version) (let* ((tail (car (last pieces))) (tail-start (car tail)) (tail-end (cdr tail))) (unless (= tail-start tail-end) (setf pieces (butlast pieces)) (cond ((string= namestr ".." :start1 tail-start :end1 tail-end) ;; ".." is a directory. Add this piece to the ;; list of pieces, and make the name/type/version ;; nil. (setf pieces (append pieces (list (cons tail-start tail-end)))) (values nil nil nil)) ((string= namestr "." :start1 tail-start :end1 tail-end) ;; "." is a directory as well. (setf pieces (append pieces (list (cons tail-start tail-end)))) (values nil nil nil)) ((not (find-if-not #'(lambda (c) (char= c #\.)) namestr :start tail-start :end tail-end)) ;; Got a bunch of dots. Make it a file of the ;; same name, and type the empty string. (values (subseq namestr tail-start (1- tail-end)) "" nil)) (t (extract-name-type-and-version namestr tail-start tail-end))))) ;; PVE: Make sure there are no illegal characters in the name ;; such as #\Null and #\/. (when (and (stringp name) (find-if #'(lambda (x) (or (char= x #\Null) (char= x #\/))) name)) (error 'parse-error)) ;; Now we have everything we want. So return it. (values nil ; no host for unix namestrings. nil ; no devices for unix namestrings. (collect ((dirs)) (when search-list (dirs (intern-search-list search-list))) (dolist (piece pieces) (let ((piece-start (car piece)) (piece-end (cdr piece))) (unless (= piece-start piece-end) (cond ((string= namestr ".." :start1 piece-start :end1 piece-end) (dirs :up)) ((string= namestr "**" :start1 piece-start :end1 piece-end) (dirs :wild-inferiors)) (t (dirs (maybe-make-pattern namestr piece-start piece-end))))))) (cond (absolute (cons :absolute (dirs))) ((dirs) ;; "." in a :relative directory is the same ;; as if it weren't there, so remove them. (cons :relative (delete "." (dirs) :test #'equal))) (t ;; If there is no directory and the name is ;; "." and the type is NIL, we really got ;; directory ".", so make it so. (if (and (equal name ".") (null type)) (list :relative) nil)))) ;; A file with name "." and type NIL can't be the name ;; of file on Unix because it's a directory. This was ;; handled above, so we can just set the name to nil. (if (and (equal name ".") (null type)) nil name) type version))))) (defun unparse-unix-host (pathname) (declare (type pathname pathname) (ignore pathname)) ;; this host designator needs to be recognized as a physical host in ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, ;; ;; No it isn't - in fact, I'm pretty sure "" is illegal here (and if ;; it isn't, it should be - it ought to mean "the default host", from ;; *default-pathname-defaults*) -- P. Foley "") (defun unparse-unix-piece (thing) (etypecase thing ((member :wild) "*") ((member :unspecific) ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific ;; cause the component not to appear in the namestring." "") (simple-string (if *ignore-wildcards* thing (let* ((srclen (length thing)) (dstlen srclen)) (dotimes (i srclen) (case (schar thing i) ((#\* #\? #\[) (incf dstlen)))) (let ((result (make-string dstlen)) (dst 0)) (dotimes (src srclen) (let ((char (schar thing src))) (case char ((#\* #\? #\[) (setf (schar result dst) #\\) (incf dst))) (setf (schar result dst) char) (incf dst))) result)))) (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) (etypecase piece (simple-string (strings piece)) (symbol (ecase piece (:multi-char-wild (strings "*")) (:single-char-wild (strings "?")))) (cons (case (car piece) (:character-set (strings "[") (strings (second piece)) (strings "]")) (t (error (intl:gettext "Invalid pattern piece: ~S") piece)))))) (apply #'concatenate 'simple-string (strings)))))) (defun unparse-unix-directory-list (directory) (declare (type list directory)) (collect ((pieces)) (when directory (ecase (pop directory) (:absolute (cond ((search-list-p (car directory)) (pieces (search-list-name (pop directory))) (pieces ":")) (t (pieces "/")))) (:relative ;; Nothing special, except if we were given '(:relative). (unless directory (pieces "./")) )) (dolist (dir directory) (typecase dir ((member :up) (pieces "../")) ((member :back) (error (intl:gettext ":BACK cannot be represented in namestrings."))) ((member :wild-inferiors) (pieces "**/")) (simple-string (when (zerop (length dir)) (error (intl:gettext "Cannot represent \"\" in namestrings."))) (when (string-equal dir "/") (error (intl:gettext "Cannot represent an explicit directory separator in namestrings."))) (pieces (unparse-unix-piece dir)) (pieces "/")) ((or pattern (eql :wild)) (pieces (unparse-unix-piece dir)) (pieces "/")) (t (error (intl:gettext "Invalid directory component: ~S") dir))))) (apply #'concatenate 'simple-string (pieces)))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) (unparse-unix-directory-list (%pathname-directory pathname))) (defun unparse-unix-file (pathname) (declare (type pathname pathname)) (collect ((strings)) (let* ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (type-supplied (not (or (null type) (eq type :unspecific)))) (logical-p (logical-pathname-p pathname)) (version (%pathname-version pathname)) ;; Preserve version :newest for logical pathnames. (version-supplied (not (or (null version) (member version (if logical-p '(:unspecific) '(:newest :unspecific))))))) (when name (when (stringp name) (when (find #\/ name) (error (intl:gettext "Cannot specify a directory separator in a pathname name: ~S") name)) (when (and (not type-supplied) (find #\. name :start 1)) ;; A single leading dot is ok. (error (intl:gettext "Cannot specify a dot in a pathname name without a pathname type: ~S") name)) (when (or (and (string= ".." name) (not type-supplied)) (and (string= "." name) (not type-supplied))) ;; Can't have a name of ".." or "." without a type. (error (intl:gettext "Invalid value for a pathname name: ~S") name))) (strings (unparse-unix-piece name))) (when type-supplied (unless name (error (intl:gettext "Cannot specify the type without a file: ~S") pathname)) (when (stringp type) (when (find #\/ type) (error (intl:gettext "Cannot specify a directory separator in a pathname type: ~S") type)) (when (find #\. type) (error (intl:gettext "Cannot specify a dot in a pathname type: ~S") type))) (strings ".") (strings (unparse-unix-piece type))) (when (and (not (member version '(nil :newest :unspecific))) (not name)) ;; We don't want version without a name, because when we try ;; to read #p".~*~" back, the name is "", not NIL. (error (intl:gettext "Cannot specify a version without a file: ~S") pathname)) (when version-supplied (strings (if (eq version :wild) (if logical-p ".*" ".~*~") (format nil (if logical-p ".~A" ".~~~D~~") version))))) (and (strings) (apply #'concatenate 'simple-string (strings))))) (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) (concatenate 'simple-string (unparse-unix-directory pathname) (unparse-unix-file pathname))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) (flet ((lose () (error (intl:gettext "~S cannot be represented relative to ~S") pathname defaults))) ;; Only the first path in a search-list is considered. (enumerate-search-list (pathname pathname) (enumerate-search-list (defaults defaults) (collect ((strings)) (let* ((pathname-directory (%pathname-directory pathname)) (defaults-directory (%pathname-directory defaults)) (prefix-len (length defaults-directory)) (result-dir (cond ((null pathname-directory) ;; No directory, so relative to default. But ;; if we're relative to default, NIL is as ;; good as '(:relative) and it results in a ;; shorter namestring. #+nil (list :relative) nil) ((and (>= prefix-len 1) (>= (length pathname-directory) prefix-len) (compare-component (subseq pathname-directory 0 prefix-len) defaults-directory)) ;; Pathname starts with a prefix of default, ;; which also means both are either :relative ;; or :absolute directories. So just use a ;; relative directory from then on out. (let ((dir-tail (nthcdr prefix-len pathname-directory))) ;; If both directories are identical, don't ;; return just :relative. Returning NIL ;; results in a shorter string. (if dir-tail (cons :relative dir-tail) nil))) ((and (eq (car pathname-directory) :relative) (not (eq (car defaults-directory) :absolute))) ;; Can't represent a relative directory ;; relative to an absolute directory. But ;; there's no problem if both are relative; ;; we just return our path. pathname-directory) ((eq (car pathname-directory) :absolute) ;; We are an absolute pathname, so we can just use it. pathname-directory) (t ;; We are a relative directory. So we lose. (lose))))) (strings (unparse-unix-directory-list result-dir))) (let* ((pathname-version (%pathname-version pathname)) (version-needed (and pathname-version (not (eq pathname-version :newest)))) (pathname-type (%pathname-type pathname)) (type-needed (or version-needed (and pathname-type (not (eq pathname-type :unspecific))))) (pathname-name (%pathname-name pathname)) (name-needed (or type-needed (and pathname-name (not (compare-component pathname-name (%pathname-name defaults))))))) (when name-needed (unless pathname-name (lose)) (strings (unparse-unix-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) (strings ".") (strings (unparse-unix-piece pathname-type))) (when version-needed (typecase pathname-version ((member :wild) (strings ".~*~")) (integer (strings (format nil ".~~~D~~" pathname-version))) (t (lose))))) (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings)))))))) (defstruct (unix-host (:include host (:parse #'parse-unix-namestring) (:unparse #'unparse-unix-namestring) (:unparse-host #'unparse-unix-host) (:unparse-directory #'unparse-unix-directory) (:unparse-file #'unparse-unix-file) (:unparse-enough #'unparse-unix-enough) (:customary-case :lower)) (:make-load-form-fun make-unix-host-load-form)) ) (defvar *unix-host* (make-unix-host)) (defun make-unix-host-load-form (host) (declare (ignore host)) '*unix-host*) ;;;; Wildcard matching stuff. (defmacro enumerate-matches ((var pathname &optional result &key (verify-existence t) (follow-links t)) &body body) (let ((body-name (gensym))) `(block nil (flet ((,body-name (,var) ,@body)) (%enumerate-matches (pathname ,pathname) ,verify-existence ,follow-links #',body-name) ,result)))) (defun %enumerate-matches (pathname verify-existence follow-links function) (when (pathname-type pathname) (unless (pathname-name pathname) (error (intl:gettext "Cannot supply a type without a name:~% ~S") pathname))) (let ((directory (pathname-directory pathname))) (if directory (ecase (car directory) (:absolute (%enumerate-directories "/" (cdr directory) pathname verify-existence follow-links nil function)) (:relative (%enumerate-directories "" (cdr directory) pathname verify-existence follow-links nil function))) (%enumerate-files "" pathname verify-existence function)))) ;;; %enumerate-directories -- Internal ;;; ;;; The directory node and device numbers are maintained for the current path ;;; during the search for the detection of path loops upon :wild-inferiors. ;;; (defun %enumerate-directories (head tail pathname verify-existence follow-links nodes function) (declare (simple-string head)) (macrolet ((unix-xstat (name) `(if follow-links (unix:unix-stat ,name) (unix:unix-lstat ,name))) (with-directory-node-noted ((head) &body body) `(multiple-value-bind (res dev ino mode) (unix-xstat ,head) ;; Even if the directory does not exist, we want to ;; continue recursing. (let ((nodes (if (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir)) (cons (cons dev ino) nodes) nodes))) ,@body))) (do-directory-entries ((name directory) &body body) `(let ((dir (unix:open-dir ,directory))) (when dir (unwind-protect (loop (let ((,name (unix:read-dir dir))) (cond ((null ,name) (return)) ((string= ,name ".")) ((string= ,name "..")) (t ,@body)))) (unix:close-dir dir)))))) (if tail (let ((piece (car tail))) (etypecase piece (simple-string (let ((head (concatenate 'string head piece))) (%enumerate-directories (concatenate 'string head "/") (cdr tail) pathname verify-existence follow-links nodes function))) ((member :wild-inferiors) (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) (do-directory-entries (name head) (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir)) (unless (dolist (dir nodes nil) (when (and (eql (car dir) dev) (eql (cdr dir) ino)) (return t))) (let ((nodes (cons (cons dev ino) nodes)) (subdir (concatenate 'string subdir "/"))) (%enumerate-directories subdir tail pathname verify-existence follow-links nodes function)))))))) ((or pattern (member :wild)) (do-directory-entries (name head) (when (or (eq piece :wild) (pattern-matches piece name)) (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir)) (let ((nodes (cons (cons dev ino) nodes)) (subdir (concatenate 'string subdir "/"))) (%enumerate-directories subdir (rest tail) pathname verify-existence follow-links nodes function)))))))) ((member :up) (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) (%enumerate-directories (concatenate 'string head "/") (rest tail) pathname verify-existence follow-links nodes function)))))) (%enumerate-files head pathname verify-existence function)))) (defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) (let ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (version (%pathname-version pathname))) (cond ((member name '(nil :unspecific)) (when (or (not verify-existence) (unix:unix-file-kind directory)) (funcall function directory))) ((or (pattern-p name) (pattern-p type) (eq name :wild) (eq type :wild) (eq version :wild)) (let ((dir (unix:open-dir directory))) (when dir (unwind-protect (loop (let ((file (unix:read-dir dir))) (if file (unless (or (string= file ".") (string= file "..")) (multiple-value-bind (file-name file-type file-version) (let ((*ignore-wildcards* t)) (extract-name-type-and-version file 0 (length file))) ;; Match also happens if the file has ;; no explicit version and we're asking ;; for version :NEWEST, since that's ;; what no version means. (when (and (components-match file-name name) (components-match file-type type) (or (components-match file-version version) (and (eq file-version nil) (eq version :newest)))) (funcall function (concatenate 'string directory file))))) (return)))) (unix:close-dir dir))))) (t (let ((file (concatenate 'string directory name))) (unless (or (null type) (eq type :unspecific)) (setf file (concatenate 'string file "." type))) (unless (member version '(nil :newest :wild :unspecific)) (setf file (concatenate 'string file ".~" (quick-integer-to-string version) "~"))) (when (or (not verify-existence) (unix:unix-file-kind file t)) (funcall function file))))))) (defun quick-integer-to-string (n) (declare (type integer n)) (cond ((not (fixnump n)) (write-to-string n :base 10 :radix nil)) ((zerop n) "0") ((eql n 1) "1") ((minusp n) (concatenate 'simple-string "-" (the simple-string (quick-integer-to-string (- n))))) (t (do* ((len (1+ (truncate (integer-length n) 3))) (res (make-string len)) (i (1- len) (1- i)) (q n) (r 0)) ((zerop q) (incf i) (replace res res :start2 i :end2 len) (shrink-vector res (- len i))) (declare (simple-string res) (fixnum len i r q)) (multiple-value-setq (q r) (truncate q 10)) (setf (schar res i) (schar "0123456789" r)))))) ;;;; UNIX-NAMESTRING -- public ;;; (defun unix-namestring (pathname &optional (for-input t) executable-only) "Convert PATHNAME into a string that can be used with UNIX system calls. Search-lists and wild-cards are expanded. If optional argument FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned. If optional argument EXECUTABLE-ONLY is true, NIL is returned unless an executable version of PATHNAME exists." ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical ;; pathnames too. (let ((path (let ((lpn (pathname pathname))) (if (logical-pathname-p lpn) (namestring (translate-logical-pathname lpn)) pathname)))) (enumerate-search-list (pathname path) (collect ((names)) (enumerate-matches (name pathname nil :verify-existence for-input :follow-links t) (when (or (not executable-only) (and (eq (unix:unix-file-kind name) :file) (unix:unix-access name unix:x_ok))) (names name))) (let ((names (names))) (when names (when (cdr names) (error 'simple-file-error :format-control (intl:gettext "~S is ambiguous:~{~% ~A~}") :format-arguments (list pathname names))) (return (car names)))))))) ;;;; TRUENAME and PROBE-FILE. ;;; Truename -- Public ;;; ;;; Another silly file function trivially different from another function. ;;; (defun truename (pathname) "Return the pathname for the actual file described by the pathname An error of type file-error is signalled if no such file exists, or the pathname is wild." (if (wild-pathname-p pathname) (error 'simple-file-error :format-control (intl:gettext "Bad place for a wild pathname.") :pathname pathname) (let ((result (probe-file pathname))) (unless result (error 'simple-file-error :pathname pathname :format-control (intl:gettext "The file ~S does not exist.") :format-arguments (list (namestring pathname)))) result))) ;;; Probe-File -- Public ;;; ;;; If PATHNAME exists, return its truename, otherwise NIL. ;;; (defun probe-file (pathname) "Return a pathname which is the truename of the file if it exists, NIL otherwise. An error of type file-error is signalled if pathname is wild." (if (wild-pathname-p pathname) (error 'simple-file-error :pathname pathname :format-control (intl:gettext "Bad place for a wild pathname.")) (let ((namestring (unix-namestring (merge-pathnames pathname) t))) (when (and namestring (unix:unix-file-kind namestring)) (let ((truename (unix:unix-resolve-links (unix:unix-maybe-prepend-current-directory namestring)))) (when truename (let ((*ignore-wildcards* t)) (pathname (unix:unix-simplify-pathname truename))))))))) ;;;; Other random operations. ;;; Rename-File -- Public ;;; (defun rename-file (file new-name) "Rename File to have the specified New-Name. If file is a stream open to a file, then the associated file is renamed. Three values are returned if successful: the defaulted new name composed of New-Name with missing components filled in from File; the truename of File before it was renamed; the new truename of the File after it was renamed." (let* ((original (truename file)) (original-namestring (unix-namestring original t)) (new-name (merge-pathnames new-name file)) (new-namestring (unix-namestring new-name nil))) (unless new-namestring (error 'simple-file-error :pathname new-name :format-control (intl:gettext "~S can't be created.") :format-arguments (list new-name))) (multiple-value-bind (res error) (unix:unix-rename original-namestring new-namestring) (unless res (error 'simple-file-error :pathname new-name :format-control (intl:gettext "Failed to rename ~A to ~A: ~A") :format-arguments (list original new-name (unix:get-unix-error-msg error)))) (when (streamp file) (file-name file new-namestring)) (values new-name original (truename new-name))))) ;;; Delete-File -- Public ;;; ;;; Delete the file, Man. ;;; (defun delete-file (file) "Delete the specified file." (let ((namestring (unix-namestring (merge-pathnames file) t))) (when (streamp file) ;; Close the file, but don't try to revert or anything. We want ;; to delete it, man! (close file)) (unless namestring (error 'simple-file-error :pathname file :format-control (intl:gettext "~S doesn't exist.") :format-arguments (list file))) (multiple-value-bind (res err) (unix:unix-unlink namestring) (unless res (error 'simple-file-error :pathname namestring :format-control (intl:gettext "Could not delete ~A: ~A.") :format-arguments (list namestring (unix:get-unix-error-msg err)))))) t) ;;; Purge-Backup-Files -- Public ;;; ;;; Purge old file versions ;;; (defun purge-backup-files (pathname &optional (keep 0)) "Delete old versions of files matching the given Pathname, optionally keeping some of the most recent old versions." (declare (type (or pathname string stream) pathname) (type (integer 0 *) keep)) (let ((hash (make-hash-table :test 'equal))) (enumerate-search-list (path (make-pathname :version :wild :defaults pathname)) (clrhash hash) (enumerate-matches (name path nil :follow-links nil) (let ((dot (position #\. name :from-end t)) (len (length name))) (when (and dot (> len (+ dot 3)) (char= (char name (1+ dot)) #\~) (char= (char name (1- len)) #\~) (eq (unix:unix-file-kind name) :file)) (multiple-value-bind (version next) (parse-integer name :start (+ dot 2) :end (1- len) :junk-allowed t) (when (and version (= next (1- len))) (push (cons version name) (gethash (subseq name 0 dot) hash '()))))))) (maphash (lambda (key value) (declare (ignore key)) (mapc #'unix:unix-unlink (mapcar #'cdr (nthcdr keep (sort value #'> :key #'car))))) hash)))) ;;; User-Homedir-Pathname -- Public ;;; ;;; Return Home:, which is set up for us at initialization time. ;;; (defun user-homedir-pathname (&optional host) "Returns the home directory of the logged in user as a pathname. This is obtained from the logical name \"home:\"." (declare (ignore host)) #p"home:") ;;; File-Write-Date -- Public ;;; (defun file-write-date (file) "Return file's creation date, or NIL if it doesn't exist. An error of type file-error is signalled if file is a wild pathname" (if (wild-pathname-p file) (error 'simple-file-error :pathname file :format-control (intl:gettext "Bad place for a wild pathname.")) (let ((name (unix-namestring (merge-pathnames file) t))) (when name (multiple-value-bind (res dev ino mode nlink uid gid rdev size atime mtime) (unix:unix-stat name) (declare (ignore dev ino mode nlink uid gid rdev size atime)) (when res (+ unix-to-universal-time mtime))))))) ;;; File-Author -- Public ;;; (defun file-author (file) "Returns the file author as a string, or nil if the author cannot be determined. Signals an error of type file-error if file doesn't exist, or file is a wild pathname." (if (wild-pathname-p file) (error 'simple-file-error :pathname file :format-control (intl:gettext "Bad place for a wild pathname.")) (let ((name (unix-namestring (merge-pathnames file) t))) (unless name (error 'simple-file-error :pathname file :format-control (intl:gettext "~S doesn't exist.") :format-arguments (list file))) (multiple-value-bind (winp dev ino mode nlink uid) (unix:unix-stat name) (declare (ignore dev ino mode nlink)) (when winp (let ((user-info (unix:unix-getpwuid uid))) (when user-info (unix:user-info-name user-info)))))))) ;;;; DIRECTORY. ;;; DIRECTORY -- public. ;;; (defun directory (pathname &key (all t) (check-for-subdirs t) (truenamep t) (follow-links t)) "Returns a list of pathnames, one for each file that matches the given pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL, then symbolic links in the result are not expanded, which is not the default because TRUENAME does follow links and the result pathnames are defined to be the TRUENAME of the pathname (the truename of a link may well be in another directory). If FOLLOW-LINKS is NIL then symbolic links are not followed." (flet ((ordered-strings-remove-duplicates (list) (let ((results '()) (prev nil)) (dolist (elem list) (when (or (null prev) (not (string= elem prev))) (push elem results)) (setf prev elem)) (nreverse results)))) (let ((results nil)) (enumerate-search-list (pathname (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild :defaults *default-pathname-defaults*) :wild)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) (or (null slash) (= (1+ slash) (length name)) (char/= (schar name (1+ slash)) #\.)))) (push name results)))) (let ((*ignore-wildcards* t)) (mapcar #'(lambda (name) (let ((name (if (and check-for-subdirs (eq (unix:unix-file-kind name) :directory)) (concatenate 'string name "/") name))) (if truenamep (truename name) (pathname name)))) (ordered-strings-remove-duplicates (sort results #'string<))))))) ;;;; Printing directories. ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package. ;;; (defun print-directory (pathname &optional stream &key all verbose return-list) "Like Directory, but prints a terse, multi-column directory listing instead of returning a list of pathnames. When :all is supplied and non-nil, then Unix dot files are included too (as ls -a). When :verbose is supplied and non-nil, then a long listing of miscellaneous information is output one file per line." (let ((*standard-output* (out-synonym-of stream)) (pathname pathname)) (if verbose (print-directory-verbose pathname all return-list) (print-directory-formatted pathname all return-list)))) (defun print-directory-verbose (pathname all return-list) (let ((contents (directory pathname :all all :check-for-subdirs nil :truenamep nil)) (result nil)) (format t (intl:gettext "Directory of ~A:~%") (namestring pathname)) (dolist (file contents) (let* ((namestring (unix-namestring file)) (tail (subseq namestring (1+ (or (position #\/ namestring :from-end t :test #'char=) -1))))) (multiple-value-bind (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime) (unix:unix-stat namestring) (declare (ignore ino gid rdev atime) (fixnum uid mode)) (cond (reslt ;; ;; Print characters for file modes. (macrolet ((frob (bit name &optional sbit sname negate) `(if ,(if negate `(not (logbitp ,bit mode)) `(logbitp ,bit mode)) ,(if sbit `(if (logbitp ,sbit mode) (write-char ,sname) (write-char ,name)) `(write-char ,name)) (write-char #\-)))) (frob 15 #\d nil nil t) (frob 8 #\r) (frob 7 #\w) (frob 6 #\x 11 #\s) (frob 5 #\r) (frob 4 #\w) (frob 3 #\x 10 #\s) (frob 2 #\r) (frob 1 #\w) (frob 0 #\x)) ;; ;; Print the rest. (multiple-value-bind (sec min hour date month year) (get-decoded-time) (declare (ignore sec min hour date month)) (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%" nlink (let ((user-info (unix:unix-getpwuid uid))) (if user-info (unix:user-info-name user-info) uid)) size (decode-universal-time-for-files mtime year) tail (= (logand mode unix:s-ifmt) unix:s-ifdir)))) (t (format t (intl:gettext "Couldn't stat ~A -- ~A.~%") tail (unix:get-unix-error-msg dev-or-err)))) (when return-list (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir) (pathname (concatenate 'string namestring "/")) file) result))))) (nreverse result))) (defun decode-universal-time-for-files (time current-year) (multiple-value-bind (sec min hour day month year) (decode-universal-time (+ time unix-to-universal-time)) (declare (ignore sec)) (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]" (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (1- month)) day (= current-year year) year hour min))) (defun print-directory-formatted (pathname all return-list) (let ((width (or (line-length *standard-output*) 80)) (names ()) (cnt 0) (max-len 0) (result (directory pathname :all all :truenamep nil))) (declare (list names) (fixnum max-len cnt)) ;; ;; Get the data. (dolist (file result) (let* ((name (unix-namestring file)) (length (length name)) (end (if (and (plusp length) (char= (schar name (1- length)) #\/)) (1- length) length)) (slash-name (subseq name (1+ (or (position #\/ name :from-end t :end end :test #'char=) -1)))) (len (length slash-name))) (declare (simple-string slash-name) (fixnum len)) (if (> len max-len) (setq max-len len)) (incf cnt) (push slash-name names))) (setq names (nreverse names)) ;; ;; Do the output. (let* ((col-width (1+ max-len)) (cols (max (truncate width col-width) 1)) (lines (ceiling cnt cols))) (declare (fixnum cols lines)) (format t (intl:gettext "Directory of ~A:~%") (namestring pathname)) (dotimes (i lines) (declare (fixnum i)) (dotimes (j cols) (declare (fixnum j)) (let ((name (nth (+ i (the fixnum (* j lines))) names))) (when name (write-string name) (unless (eql j (1- cols)) (dotimes (i (- col-width (length (the simple-string name)))) (write-char #\space)))))) (terpri))) (when return-list result))) ;;;; File completion. ;;; COMPLETE-FILE -- Public ;;; (defun complete-file (pathname &key (defaults *default-pathname-defaults*) ignore-types) (let ((files (directory (complete-file-directory-arg pathname defaults) :check-for-subdirs nil :truenamep nil))) (cond ((null files) (values nil nil)) ((null (cdr files)) (values (merge-pathnames (file-namestring (car files)) pathname) t)) (t (let ((good-files (delete-if #'(lambda (pathname) (and (simple-string-p (pathname-type pathname)) (member (pathname-type pathname) ignore-types :test #'string=))) files))) (cond ((null good-files)) ((null (cdr good-files)) (return-from complete-file (values (merge-pathnames (file-namestring (car good-files)) pathname) t))) (t (setf files good-files))) (let ((common (file-namestring (car files)))) (dolist (file (cdr files)) (let ((name (file-namestring file))) (dotimes (i (min (length common) (length name)) (when (< (length name) (length common)) (setf common name))) (unless (char= (schar common i) (schar name i)) (setf common (subseq common 0 i)) (return))))) (values (merge-pathnames common pathname) nil))))))) ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal. ;;; (defun complete-file-directory-arg (pathname defaults) (let* ((pathname (merge-pathnames pathname (directory-namestring defaults))) (type (pathname-type pathname))) (flet ((append-multi-char-wild (thing) (etypecase thing (null :wild) (pattern (make-pattern (append (pattern-pieces thing) (list :multi-char-wild)))) (simple-string (make-pattern (list thing :multi-char-wild)))))) (if (or (null type) (eq type :unspecific)) ;; There is no type. (make-pathname :defaults pathname :name (append-multi-char-wild (pathname-name pathname)) :type :wild) ;; There already is a type, so just extend it. (make-pathname :defaults pathname :name (pathname-name pathname) :type (append-multi-char-wild (pathname-type pathname))))))) ;;; Ambiguous-Files -- Public ;;; (defun ambiguous-files (pathname &optional (defaults *default-pathname-defaults*)) "Return a list of all files which are possible completions of Pathname. We look in the directory specified by Defaults as well as looking down the search list." (directory (complete-file-directory-arg pathname defaults) :truenamep nil :check-for-subdirs nil)) ;;; File-writable -- exported from extensions. ;;; ;;; Determines whether the single argument (which should be a pathname) ;;; can be written by the current task. ;;; (defun file-writable (name) "File-writable accepts a pathname and returns T if the current process can write it, and NIL otherwise." (let ((name (unix-namestring name nil))) (cond ((null name) nil) ((unix:unix-file-kind name) (values (unix:unix-access name unix:w_ok))) (t (values (unix:unix-access (subseq name 0 (or (position #\/ name :from-end t) 0)) (logior unix:w_ok unix:x_ok))))))) ;;; Pathname-Order -- Internal ;;; ;;; Predicate to order pathnames by. Goes by name. ;;; (defun pathname-order (x y) (let ((xn (%pathname-name x)) (yn (%pathname-name y))) (if (and xn yn) (let ((res (string-lessp xn yn))) (cond ((not res) nil) ((= res (length (the simple-string xn))) t) ((= res (length (the simple-string yn))) nil) (t t))) xn))) ;;; Default-Directory -- Public ;;; (defun default-directory () "Returns the pathname for the default directory. This is the place where a file will be written if no directory is specified. This may be changed with setf." (multiple-value-bind (gr dir-or-error) (unix:unix-current-directory) (if gr (let ((*ignore-wildcards* t)) (values (parse-namestring (concatenate 'simple-string dir-or-error "/") *unix-host*))) (error dir-or-error)))) ;;; %Set-Default-Directory -- Internal ;;; (defun %set-default-directory (new-val) (let ((namestring (unix-namestring new-val t))) (unless namestring (error 'simple-file-error :format-control (intl:gettext "~S doesn't exist.") :format-arguments (list new-val))) (multiple-value-bind (gr error) (unix:unix-chdir namestring) (if gr (setf (search-list "default:") (default-directory)) (error (unix:get-unix-error-msg error)))) new-val)) ;;; (defsetf default-directory %set-default-directory) (defun filesys-init () ;; Use :unspecific so we don't create file versions whenever merging ;; happens. If the user wants that, let him change ;; *default-pathname-defaults* appropriately. (setf *default-pathname-defaults* (%make-pathname *unix-host* nil nil nil nil :unspecific)) (setf (search-list "default:") (default-directory)) nil) ;;; Ensure-Directories-Exist -- Public ;;; (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) "Tests whether the directories containing the specified file actually exist, and attempts to create them if they do not. Portable programs should avoid using the :MODE keyword argument." (let* ((pathname (merge-pathnames pathspec)) (pathname (if (logical-pathname-p pathname) (translate-logical-pathname pathname) pathname)) (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error :format-control (intl:gettext "Bad place for a wild pathname.") :pathname pathspec)) (enumerate-search-list (pathname pathname) (let ((dir (pathname-directory pathname))) (loop for i from 1 upto (length dir) do (let ((newpath (make-pathname :host (pathname-host pathname) :device (pathname-device pathname) :directory (subseq dir 0 i)))) (tagbody retry (restart-case (unless (probe-file newpath) (let ((namestring (namestring newpath))) (when verbose (format *standard-output* (intl:gettext "~&Creating directory: ~A~%") namestring)) (unix:unix-mkdir namestring mode) (unless (probe-file namestring) (error 'simple-file-error :pathname pathspec :format-control (intl:gettext "Can't create directory ~A.") :format-arguments (list namestring))) (setf created-p t))) (retry () :report "Try to create the directory again" (go retry)))))) ;; Only the first path in a search-list is considered. (return (values pathname created-p)))))) cmucl-21a/src/code/final.lisp000066400000000000000000000035761260377556400162570ustar00rootroot00000000000000;;; -*- Package: EXTENSIONS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/final.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Finalization based on weak pointers. Written by William Lott, but ;;; the idea really was Chris Hoover's. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(finalize cancel-finalization)) (defvar *objects-pending-finalization* nil) (defun finalize (object function) "Arrange for FUNCTION to be called when there are no more references to OBJECT. FUNCTION takes no arguments." (declare (type function function)) (system:without-gcing (push (cons (make-weak-pointer object) function) *objects-pending-finalization*)) object) (defun cancel-finalization (object) "Cancel any finalization registers for OBJECT." (when object ;; We check to make sure object isn't nil because if there are any ;; broken weak pointers, their value will show up as nil. Therefore, ;; they would be deleted from the list, but not finalized. Broken ;; weak pointers shouldn't be left in the list, but why take chances? (system:without-gcing (setf *objects-pending-finalization* (delete object *objects-pending-finalization* :key #'(lambda (pair) (values (weak-pointer-value (car pair)))))))) nil) (defun finalize-corpses () (setf *objects-pending-finalization* (delete-if #'(lambda (pair) (multiple-value-bind (object valid) (weak-pointer-value (car pair)) (declare (ignore object)) (unless valid (funcall (cdr pair)) t))) *objects-pending-finalization*)) nil) (pushnew 'finalize-corpses *after-gc-hooks*) cmucl-21a/src/code/float-trap.lisp000066400000000000000000000362541260377556400172360ustar00rootroot00000000000000;;; -*- Package: VM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/float-trap.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains stuff for controlling floating point traps. It is ;;; IEEE float specific, but should work for pretty much any FPU where the ;;; state fits in one word and exceptions are represented by bits being set. ;;; ;;; Author: Rob MacLachlan ;;; (in-package "VM") (intl:textdomain "cmucl") (eval-when (:compile-toplevel :load-toplevel :execute) (export '(current-float-trap floating-point-modes sigfpe-handler)) ) (in-package "EXTENSIONS") (export '(set-floating-point-modes get-floating-point-modes with-float-traps-masked)) (in-package "VM") (eval-when (compile load eval) (defconstant float-trap-alist (list (cons :underflow float-underflow-trap-bit) (cons :overflow float-overflow-trap-bit) (cons :inexact float-inexact-trap-bit) (cons :invalid float-invalid-trap-bit) (cons :divide-by-zero float-divide-by-zero-trap-bit) #+x86 (cons :denormalized-operand float-denormal-trap-bit))) ;;; FLOAT-TRAP-MASK -- Internal ;;; ;;; Return a mask with all the specified float trap bits set. ;;; (defun float-trap-mask (names) (reduce #'logior (mapcar #'(lambda (x) (or (cdr (assoc x float-trap-alist)) (error (intl:gettext "Unknown float trap kind: ~S.") x))) names))) (defconstant rounding-mode-alist (list (cons :nearest float-round-to-nearest) (cons :zero float-round-to-zero) (cons :positive-infinity float-round-to-positive) (cons :negative-infinity float-round-to-negative))) ); Eval-When (Compile Load Eval) ;;; Interpreter stubs. ;;; #+(not x86) (progn (defun floating-point-modes () (floating-point-modes)) (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) ) #+(and x86 (not sse2)) (progn (defun floating-point-modes () (let ((x87-modes (vm::x87-floating-point-modes))) ;; Massage the bits from x87-floating-point-modes into the order ;; that the rest of the system wants them to be. (Must match ;; format in the SSE2 mxcsr register.) (logior (ash (logand #x3f x87-modes) 7) ; control (logand #x3f (ash x87-modes -16))))) (defun (setf floating-point-modes) (new) (let* ((rc (ldb float-rounding-mode new)) (x87-modes (logior (ash (logand #x3f new) 16) (ash rc 10) (logand #x3f (ash new -7)) ;; Set precision control to be 53-bit, always. ;; (The compiler takes care of handling ;; single-float precision, and we don't support ;; long-floats.) (ash 2 8)))) (setf (x87-floating-point-modes) x87-modes))) ) #+(and sse2 (not darwin)) (progn (defun floating-point-modes () ;; Combine the modes from the FPU and SSE2 units. Since the sse ;; mode contains all of the common information we want, we massage ;; the x87-modes to match, and then OR the x87 and sse2 modes ;; together. Note: We ignore the rounding control bits from the ;; FPU and only use the SSE2 rounding control bits. (let* ((x87-modes (vm::x87-floating-point-modes)) (sse-modes (vm::sse2-floating-point-modes)) (final-mode (logior sse-modes (ash (logand #x3f x87-modes) 7) ; control (logand #x3f (ash x87-modes -16))))) final-mode)) (defun (setf floating-point-modes) (new-mode) (declare (type (unsigned-byte 24) new-mode)) ;; Set the floating point modes for both X87 and SSE2. This ;; include the rounding control bits. (let* ((rc (ldb float-rounding-mode new-mode)) (x87-modes (logior (ash (logand #x3f new-mode) 16) (ash rc 10) (logand #x3f (ash new-mode -7)) ;; Set precision control to be 64-bit, always. We ;; don't use the x87 registers with sse2, so this ;; is ok and would be the correct setting if we ;; ever support long-floats. (ash 3 8)))) (setf (vm::sse2-floating-point-modes) new-mode) (setf (vm::x87-floating-point-modes) x87-modes)) new-mode) ) #+(and sse2 darwin) (progn (defun floating-point-modes () ;; Get just the SSE2 mode bits. (vm::sse2-floating-point-modes)) (defun (setf floating-point-modes) (new-mode) (declare (type (unsigned-byte 24) new-mode)) ;; Set the floating point modes for SSE2. (setf (vm::sse2-floating-point-modes) new-mode) new-mode) ) ;;; SET-FLOATING-POINT-MODES -- Public ;;; (defun set-floating-point-modes (&key (traps nil traps-p) (rounding-mode nil round-p) (current-exceptions nil current-x-p) (accrued-exceptions nil accrued-x-p) (fast-mode nil fast-mode-p)) "This function sets options controlling the floating-point hardware. If a keyword is not supplied, then the current value is preserved. Possible keywords: :TRAPS A list of the exception conditions that should cause traps. Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID, :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially all traps except :INEXACT are enabled. :ROUNDING-MODE The rounding mode to use when the result is not exact. Possible values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO. Initially, the rounding mode is :NEAREST. :CURRENT-EXCEPTIONS :ACCRUED-EXCEPTIONS These arguments allow setting of the exception flags. The main use is setting the accrued exceptions to NIL to clear them. :FAST-MODE Set the hardware's \"fast mode\" flag, if any. When set, IEEE conformance or debuggability may be impaired. Some machines may not have this feature, in which case the value is always NIL. GET-FLOATING-POINT-MODES may be used to find the floating point modes currently in effect." (let ((modes (floating-point-modes))) (when traps-p (let ((trap-mask-bits (float-trap-mask traps))) (setf (ldb float-traps-byte modes) trap-mask-bits) #+(and x86 sse2) (progn ;; Clear out any current or accrued exceptions that match ;; the traps that we are enabling. If we don't then ;; enabling the traps causes the exceptions to be signaled ;; immediately. This is a bit annoying. If the user really ;; wants to resignal the exceptions, he can do that himself. (setf (ldb float-sticky-bits modes) (logandc2 (ldb float-sticky-bits modes) trap-mask-bits)) (setf (ldb float-exceptions-byte modes) (logandc2 (ldb float-exceptions-byte modes) trap-mask-bits))))) (when round-p (setf (ldb float-rounding-mode modes) (or (cdr (assoc rounding-mode rounding-mode-alist)) (error (intl:gettext "Unknown rounding mode: ~S.") rounding-mode)))) (when current-x-p (setf (ldb float-exceptions-byte modes) (float-trap-mask current-exceptions)) #+(and darwin ppc) (when (member :invalid current-exceptions) ;; Clear out the bits for the detected invalid operation (setf (ldb vm:float-invalid-op-1-byte modes) 0) (setf (ldb vm:float-invalid-op-2-byte modes) 0))) (when accrued-x-p (setf (ldb float-sticky-bits modes) (float-trap-mask accrued-exceptions)) #+(and darwin ppc) (when (member :invalid current-exceptions) ;; Clear out the bits for the detected invalid operation (setf (ldb vm:float-invalid-op-1-byte modes) 0) (setf (ldb vm:float-invalid-op-2-byte modes) 0))) #+(and darwin ppc) (when (or accrued-x-p current-x-p) (setf (ldb vm:float-exceptions-summary-byte modes) 0)) (when fast-mode-p (if fast-mode (setq modes (logior float-fast-bit modes)) (setq modes (logand (lognot float-fast-bit) modes)))) (setf (floating-point-modes) modes)) (values)) ;;; GET-FLOATING-POINT-MODES -- Public ;;; (defun get-floating-point-modes () "This function returns a list representing the state of the floating point modes. The list is in the same format as the keyword arguments to SET-FLOATING-POINT-MODES, i.e. (apply #'set-floating-point-modes (get-floating-point-modes)) sets the floating point modes to their current values (and thus is a no-op)." (flet ((exc-keys (bits) (macrolet ((frob () `(collect ((res)) ,@(mapcar #'(lambda (x) `(when (logtest bits ,(cdr x)) (res ',(car x)))) float-trap-alist) (res)))) (frob)))) (let ((modes (floating-point-modes))) `(:traps ,(exc-keys (ldb float-traps-byte modes)) :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) rounding-mode-alist)) :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) :fast-mode ,(logtest float-fast-bit modes))))) ;;; CURRENT-FLOAT-TRAP -- Interface ;;; (defmacro current-float-trap (&rest traps) "Current-Float-Trap Trap-Name* Return true if any of the named traps are currently trapped, false otherwise." `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0) (floating-point-modes))))) ;;; SIGFPE-HANDLER -- Interface ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; (defun sigfpe-handler (signal code scp) (declare (ignore signal) (type system-area-pointer scp)) (let* ((modes (sigcontext-floating-point-modes (alien:sap-alien scp (* unix:sigcontext)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) #+(and darwin ppc) (let* ((new-modes modes) (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) traps))) ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) (setf (ldb float-exceptions-byte new-modes) new-exceptions) ;; Clear out all exceptions and save them to the context. ;; ;; XXX: Should we just clear out the bits for the traps that are ;; enabled? If we did that then the accrued exceptions would be ;; correct. (setf (ldb float-sticky-bits new-modes) 0) ;; Clear out the various sticky invalid operation bits too. ;; ;; XXX: Should we only do that if the invalid trap is enabled? (setf (ldb float-invalid-op-1-byte new-modes) 0) (setf (ldb float-invalid-op-2-byte new-modes) 0) ;; Clear the FP exception summary bit too. (setf (ldb float-exceptions-summary-byte new-modes) 0) ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) (setf (floating-point-modes) new-modes) (setf (sigcontext-floating-point-modes (alien:sap-alien scp (* unix:sigcontext))) new-modes)) #+sse2 (let* ((new-modes modes) (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) traps))) ;; Clear out the status for any enabled traps. With SSE2, if ;; the current exception is enabled, the next FP instruction ;; will cause the exception to be signaled again. Hence, we ;; need to clear out the exceptions that we are handling here. (setf (ldb float-exceptions-byte new-modes) new-exceptions) ;; XXX: This seems not right. Shouldn't we be setting the modes ;; in the sigcontext instead? This however seems to do what we ;; want. (setf (vm:floating-point-modes) new-modes)) (multiple-value-bind (fop operands) (let ((sym (find-symbol "GET-FP-OPERANDS" "VM"))) (if (fboundp sym) (funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes) (values nil nil))) (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) (error 'division-by-zero :operation fop :operands operands)) ((not (zerop (logand float-invalid-trap-bit traps))) (error 'floating-point-invalid-operation :operation fop :operands operands)) ((not (zerop (logand float-overflow-trap-bit traps))) (error 'floating-point-overflow :operation fop :operands operands)) ((not (zerop (logand float-underflow-trap-bit traps))) (error 'floating-point-underflow :operation fop :operands operands)) ((not (zerop (logand float-inexact-trap-bit traps))) (error 'floating-point-inexact :operation fop :operands operands)) #+x86 ((not (zerop (logand float-denormal-trap-bit traps))) (error 'floating-point-denormal-operand :operation fop :operands operands)) (t ;; It looks like the sigcontext on Solaris/x86 doesn't ;; actually save the status word of the FPU. The ;; operands also seem to be missing. Signal a general ;; arithmetic error. #+(and x86 solaris) (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" code) ;; For all other x86 ports, we should only get here if ;; the SIGFPE was caused by an integer overflow on ;; division. For sparc and ppc, I (rtoy) don't think ;; there's any other way to get here since integer ;; overflows aren't signaled. ;; ;; In that case, FOP should be /, so we can generate a ;; nice arithmetic-error. It's possible to use CODE, ;; which is supposed to indicate what caused the ;; exception, but each OS is different, so we don't; FOP ;; can tell us. #-(and x86 solaris) (if fop (error 'arithmetic-error :operation fop :operands operands) (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" code))))))) ;;; WITH-FLOAT-TRAPS-MASKED -- Public ;;; (defmacro with-float-traps-masked (traps &body body) "Execute BODY with the floating point exceptions listed in TRAPS masked (disabled). TRAPS should be a list of possible exceptions which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective accrued exceptions are cleared at the start of the body to support their testing within, and restored on exit." (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0)) (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0)) (trap-mask (dpb (lognot (float-trap-mask traps)) float-traps-byte #xffffffff)) (exception-mask (dpb (lognot (vm::float-trap-mask traps)) float-sticky-bits #xffffffff)) ;; On ppc if we are masking the invalid trap, we need to make ;; sure we wipe out the various individual sticky bits ;; representing the invalid operation. Otherwise, if we ;; enable the invalid trap later, these sticky bits will cause ;; an exception. #+ppc (invalid-mask (if (member :invalid traps) (dpb 0 (byte 1 31) (dpb 0 vm::float-invalid-op-2-byte (dpb 0 vm:float-invalid-op-1-byte #xffffffff))) #xffffffff)) (orig-modes (gensym))) `(let ((,orig-modes (floating-point-modes))) (unwind-protect (progn (setf (floating-point-modes) (logand ,orig-modes ,(logand trap-mask exception-mask))) ,@body) ;; Restore the original traps and exceptions. (setf (floating-point-modes) (logior (logand ,orig-modes ,(logior traps exceptions)) (logand (floating-point-modes) ,(logand trap-mask exception-mask) #+ppc ,invalid-mask #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))) cmucl-21a/src/code/float.lisp000066400000000000000000001661161260377556400162730ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/float.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the definitions of float specific number support ;;; (other than irrational stuff, which is in irrat.) There is code in here ;;; that assumes there are only two float formats: IEEE single and double. ;;; ;;; Author: Rob MacLachlan ;;; Long-float support by Douglas Crosher, 1998. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") (export '(%unary-truncate %unary-round %unary-ftruncate %unary-ftruncate/single-float %unary-ftruncate/double-float)) #-x87 (export '(%unary-fround/single-float %unary-fround/double-float)) (in-package "LISP") (export '(least-positive-normalized-short-float least-positive-normalized-single-float least-positive-normalized-double-float least-positive-normalized-long-float least-negative-normalized-short-float least-negative-normalized-single-float least-negative-normalized-double-float least-negative-normalized-long-float least-positive-single-float least-positive-short-float least-negative-single-float least-negative-short-float least-positive-double-float least-positive-long-float least-negative-double-float least-negative-long-float most-positive-single-float most-positive-short-float most-negative-single-float most-negative-short-float most-positive-double-float most-positive-long-float most-negative-double-float most-negative-long-float)) (in-package "EXTENSIONS") (export '(single-float-positive-infinity short-float-positive-infinity double-float-positive-infinity long-float-positive-infinity single-float-negative-infinity short-float-negative-infinity double-float-negative-infinity long-float-negative-infinity set-floating-point-modes float-denormalized-p float-nan-p float-trapping-nan-p float-infinity-p float-signaling-nan-p)) #+double-double (export '(least-positive-normalized-double-double-float least-negative-normalized-double-double-float least-positive-double-double-float least-negative-double-double-float most-positive-double-double-float most-negative-double-double-float double-double-float-negative-infinity)) (in-package "KERNEL") ;;;; Utilities: ;;; SINGLE-FROM-BITS, DOUBLE-FROM-BITS -- Internal ;;; ;;; These functions let us create floats from bits with the significand ;;; uniformly represented as an integer. This is less efficient for double ;;; floats, but is more convenient when making special values, etc. ;;; (defun single-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 24) sig) (type (unsigned-byte 8) exp)) (make-single-float (dpb exp vm:single-float-exponent-byte (dpb sig vm:single-float-significand-byte (if (zerop sign) 0 -1))))) ;;; (defun double-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 53) sig) (type (unsigned-byte 11) exp)) (make-double-float (dpb exp vm:double-float-exponent-byte (dpb (ash sig -32) vm:double-float-significand-byte (if (zerop sign) 0 -1))) (ldb (byte 32 0) sig))) #+double-double (defun double-double-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte #.vm:double-double-float-digits) sig) (type (unsigned-byte 11) exp) (ignore exp)) (let ((lo (ldb (byte vm:double-float-digits 0) sig)) (hi (ldb (byte vm:double-float-digits vm:double-float-digits) sig)) (fsign (- 1 (* 2 sign)))) ;; We can't return a double-double because exp might be very ;; small, and the low part of the double-double would get scaled ;; to 0. So we return both parts and expect the caller to figure ;; out what to do. (values (scale-float (* fsign (float hi 1d0)) #.(- vm:double-float-digits)) (scale-float (* fsign (float lo 1d0)) #.(- vm:double-float-digits))))) ;;; #+(and long-float x86) (defun long-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 64) sig) (type (unsigned-byte 15) exp)) (make-long-float (logior (ash sign 15) exp) (ldb (byte 32 32) sig) (ldb (byte 32 0) sig))) ;;;; Float parameters: (defconstant least-positive-single-float (single-from-bits 0 0 1)) (defconstant least-positive-short-float least-positive-single-float) (defconstant least-negative-single-float (single-from-bits 1 0 1)) (defconstant least-negative-short-float least-negative-single-float) (defconstant least-positive-double-float (double-from-bits 0 0 1)) #-long-float (defconstant least-positive-long-float least-positive-double-float) #+(and long-float x86) (defconstant least-positive-long-float (long-from-bits 0 0 1)) (defconstant least-negative-double-float (double-from-bits 1 0 1)) #-long-float (defconstant least-negative-long-float least-negative-double-float) #+(and long-float x86) (defconstant least-negative-long-float (long-from-bits 1 0 1)) #+double-double (progn (defconstant least-positive-normalized-double-double-float ;; What is the right value? (kernel:%make-double-double-float least-positive-normalized-double-float 0d0)) (defconstant least-negative-normalized-double-double-float ;; What is the right value? (kernel:%make-double-double-float least-negative-normalized-double-float 0d0)) (defconstant least-positive-double-double-float (kernel:%make-double-double-float least-positive-double-float 0d0)) (defconstant least-negative-double-double-float (kernel:%make-double-double-float least-negative-double-float 0d0)) (defconstant most-positive-double-double-float ;; What is the right value? (kernel:%make-double-double-float most-positive-double-float 0d0)) (defconstant most-negative-double-double-float ;; What is the right value? (kernel:%make-double-double-float most-negative-double-float 0d0)) (defconstant double-double-float-positive-infinity ;; What is the right value? (kernel:%make-double-double-float double-float-positive-infinity 0d0)) (defconstant double-double-float-negative-infinity ;; What is the right value? (kernel:%make-double-double-float double-float-negative-infinity 0d0)) ); double-double (defconstant least-positive-normalized-single-float (single-from-bits 0 vm:single-float-normal-exponent-min 0)) (defconstant least-positive-normalized-short-float least-positive-normalized-single-float) (defconstant least-negative-normalized-single-float (single-from-bits 1 vm:single-float-normal-exponent-min 0)) (defconstant least-negative-normalized-short-float least-negative-normalized-single-float) (defconstant least-positive-normalized-double-float (double-from-bits 0 vm:double-float-normal-exponent-min 0)) #-long-float (defconstant least-positive-normalized-long-float least-positive-normalized-double-float) #+(and long-float x86) (defconstant least-positive-normalized-long-float (long-from-bits 0 vm:long-float-normal-exponent-min (ash vm:long-float-hidden-bit 32))) (defconstant least-negative-normalized-double-float (double-from-bits 1 vm:double-float-normal-exponent-min 0)) #-long-float (defconstant least-negative-normalized-long-float least-negative-normalized-double-float) #+(and long-float x86) (defconstant least-negative-normalized-long-float (long-from-bits 1 vm:long-float-normal-exponent-min (ash vm:long-float-hidden-bit 32))) (defconstant most-positive-single-float (single-from-bits 0 vm:single-float-normal-exponent-max (ldb vm:single-float-significand-byte -1))) (defconstant most-positive-short-float most-positive-single-float) (defconstant most-negative-single-float (single-from-bits 1 vm:single-float-normal-exponent-max (ldb vm:single-float-significand-byte -1))) (defconstant most-negative-short-float most-negative-single-float) (defconstant most-positive-double-float (double-from-bits 0 vm:double-float-normal-exponent-max (ldb (byte vm:double-float-digits 0) -1))) #-long-float (defconstant most-positive-long-float most-positive-double-float) #+(and long-float x86) (defconstant most-positive-long-float (long-from-bits 0 vm:long-float-normal-exponent-max (ldb (byte vm:long-float-digits 0) -1))) (defconstant most-negative-double-float (double-from-bits 1 vm:double-float-normal-exponent-max (ldb (byte vm:double-float-digits 0) -1))) #-long-float (defconstant most-negative-long-float most-negative-double-float) #+(and long-float x86) (defconstant most-negative-long-float (long-from-bits 1 vm:long-float-normal-exponent-max (ldb (byte vm:long-float-digits 0) -1))) (defconstant single-float-positive-infinity (single-from-bits 0 (1+ vm:single-float-normal-exponent-max) 0)) (defconstant short-float-positive-infinity single-float-positive-infinity) (defconstant single-float-negative-infinity (single-from-bits 1 (1+ vm:single-float-normal-exponent-max) 0)) (defconstant short-float-negative-infinity single-float-negative-infinity) (defconstant double-float-positive-infinity (double-from-bits 0 (1+ vm:double-float-normal-exponent-max) 0)) #-long-float (defconstant long-float-positive-infinity double-float-positive-infinity) #+(and long-float x86) (defconstant long-float-positive-infinity (long-from-bits 0 (1+ vm:long-float-normal-exponent-max) (ash vm:long-float-hidden-bit 32))) (defconstant double-float-negative-infinity (double-from-bits 1 (1+ vm:double-float-normal-exponent-max) 0)) #-long-float (defconstant long-float-negative-infinity double-float-negative-infinity) #+(and long-float x86) (defconstant long-float-negative-infinity (long-from-bits 1 (1+ vm:long-float-normal-exponent-max) (ash vm:long-float-hidden-bit 32))) (defconstant single-float-epsilon (single-from-bits 0 (- vm:single-float-bias (1- vm:single-float-digits)) 1)) (defconstant short-float-epsilon single-float-epsilon) (defconstant single-float-negative-epsilon (single-from-bits 0 (- vm:single-float-bias vm:single-float-digits) 1)) (defconstant short-float-negative-epsilon single-float-negative-epsilon) #-(and long-float x86) (defconstant double-float-epsilon (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) 1)) #+(and long-float x86) (defconstant double-float-epsilon (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) (expt 2 42))) #-long-float (defconstant long-float-epsilon double-float-epsilon) #+(and long-float x86) (defconstant long-float-epsilon (long-from-bits 0 (- vm:long-float-bias (1- vm:long-float-digits)) (+ 1 (ash vm:long-float-hidden-bit 32)))) #-(and long-float x86) (defconstant double-float-negative-epsilon (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) 1)) #+(and long-float x86) (defconstant double-float-negative-epsilon (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) (expt 2 42))) #-long-float (defconstant long-float-negative-epsilon double-float-negative-epsilon) #+(and long-float x86) (defconstant long-float-negative-epsilon (long-from-bits 0 (- vm:long-float-bias vm:long-float-digits) (+ 1 (ash vm:long-float-hidden-bit 32)))) ;;;; Float predicates and environment query: (declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p float-signaling-nan-p)) ;;; FLOAT-DENORMALIZED-P -- Public ;;; (defun float-denormalized-p (x) "Return true if the float X is denormalized." (number-dispatch ((x float)) ((single-float) (and (zerop (ldb vm:single-float-exponent-byte (single-float-bits x))) (not (zerop x)))) ((double-float) (and (zerop (ldb vm:double-float-exponent-byte (double-float-high-bits x))) (not (zerop x)))) #+(and long-float x86) ((long-float) (and (zerop (ldb vm:long-float-exponent-byte (long-float-exp-bits x))) (not (zerop x)))))) (macrolet ((frob (name doc single double #+(and long-float x86) long #+double-double double-double) `(defun ,name (x) ,doc (number-dispatch ((x float)) ((single-float) (let ((bits (single-float-bits x))) (and (> (ldb vm:single-float-exponent-byte bits) vm:single-float-normal-exponent-max) ,single))) ((double-float) (let ((hi (double-float-high-bits x)) (lo (double-float-low-bits x))) (declare (ignorable lo)) (and (> (ldb vm:double-float-exponent-byte hi) vm:double-float-normal-exponent-max) ,double))) #+(and long-float x86) ((long-float) (let ((exp (long-float-exp-bits x)) (hi (long-float-high-bits x)) (lo (long-float-low-bits x))) (declare (ignorable lo)) (and (> (ldb vm:long-float-exponent-byte exp) vm:long-float-normal-exponent-max) ,long))) #+double-double ((double-double-float) ,double-double))))) (frob float-infinity-p "Return true if the float X is an infinity (+ or -)." (zerop (ldb vm:single-float-significand-byte bits)) (and (zerop (ldb vm:double-float-significand-byte hi)) (zerop lo)) #+(and long-float x86) (and (zerop (ldb vm:long-float-significand-byte hi)) (zerop lo)) #+double-double (float-infinity-p (double-double-hi x))) (frob float-nan-p "Return true if the float X is a quiet or signaling NaN (Not a Number)." (not (zerop (ldb vm:single-float-significand-byte bits))) (or (not (zerop (ldb vm:double-float-significand-byte hi))) (not (zerop lo))) #+(and long-float x86) (or (not (zerop (ldb vm:long-float-significand-byte hi))) (not (zerop lo))) #+double-double (float-nan-p (double-double-hi x))) (frob float-signaling-nan-p "Return true if the float X is a signaling NaN (Not a Number)." (zerop (logand (ldb vm:single-float-significand-byte bits) vm:single-float-trapping-nan-bit)) (zerop (logand (ldb vm:double-float-significand-byte hi) vm:double-float-trapping-nan-bit)) #+(and long-float x86) (zerop (logand (ldb vm:long-float-significand-byte hi) vm:long-float-trapping-nan-bit)) #+double-double (float-signaling-nan-p (double-double-hi x)))) (declaim (inline float-trapping-nan-p)) (defun float-trapping-nan-p (x) "Deprecated. Use FLOAT-SIGNALING-NAN-P instead." (float-signaling-nan-p x)) ;;; FLOAT-PRECISION -- Public ;;; ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the ;;; actual exponent (and hence how denormalized it is), otherwise we just ;;; return the number of digits or 0. ;;; (declaim (maybe-inline float-precision)) (defun float-precision (f) "Returns a non-negative number of significant digits in it's float argument. Will be less than FLOAT-DIGITS if denormalized or zero." (macrolet ((frob (digits bias decode) `(cond ((zerop f) 0) ((float-denormalized-p f) (multiple-value-bind (ignore exp) (,decode f) (declare (ignore ignore)) (truly-the fixnum (+ ,digits (1- ,digits) ,bias exp)))) (t ,digits)))) (number-dispatch ((f float)) ((single-float) (frob vm:single-float-digits vm:single-float-bias integer-decode-single-denorm)) ((double-float) (frob vm:double-float-digits vm:double-float-bias integer-decode-double-denorm)) #+long-float ((long-float) (frob vm:long-float-digits vm:long-float-bias integer-decode-long-denorm)) #+double-double ((double-double-float) ;; What exactly is the precision for a double-double? We make ;; it the sum of the precisions of the two components. (let ((hi (double-double-hi f))) (cond ((zerop hi) ;; ANSI CL says the precision is 0 0) ((< (abs hi) (scale-float least-positive-normalized-double-float 53)) ;; For every power of 2 below this, we lose a bit of ;; precision. More or less. (let ((cutoff (nth-value 1 (decode-float (scale-float least-positive-normalized-double-float 53))))) (multiple-value-bind (f exp) (decode-float hi) (declare (ignore f)) (- 106 (- cutoff exp))))) (t ;; Normally we have 106 bits of precision (twice the ;; double-float precision) 106))))))) #+nil (defun float-sign (float1 &optional (float2 (float 1 float1))) "Returns a floating-point number that has the same sign as float1 and, if float2 is given, has the same absolute value as float2." (declare (float float1 float2)) (* (if (etypecase float1 (single-float (minusp (single-float-bits float1))) (double-float (minusp (double-float-high-bits float1))) #+long-float (long-float (minusp (long-float-exp-bits float1))) #+double-double (double-double-float (minusp (double-double-hi float1)))) (float -1 float1) (float 1 float1)) (abs float2))) (defun float-sign (float1 &optional float2) "Returns a floating-point number that has the same sign as float1 and, if float2 is given, has the same absolute value as float2." (declare (float float1) (type (or null float) float2)) (let ((f1-sign (if (etypecase float1 (single-float (minusp (single-float-bits float1))) (double-float (minusp (double-float-high-bits float1))) #+long-float (long-float (minusp (long-float-exp-bits float1))) #+double-double (double-double-float (minusp (float-sign (double-double-hi float1))))) (float -1 float1) (float 1 float1)))) ;; Multiplication of double-double-float's doesn't preserve the ;; sign of signed-zeroes, so we split the case of float2 this way ;; so we can get the right sign. (if float2 (if (minusp f1-sign) (- (abs float2)) (abs float2)) f1-sign))) (defun float-format-digits (format) (ecase format ((short-float single-float) vm:single-float-digits) ((double-float #-long-float long-float) vm:double-float-digits) #+long-float (long-float vm:long-float-digits) #+double-double (double-double-float vm:double-double-float-digits))) (declaim (inline float-digits float-radix)) (defun float-digits (f) "Returns a non-negative number of radix-b digits used in the representation of it's argument. See Common Lisp: The Language by Guy Steele for more details." (number-dispatch ((f float)) ((single-float) vm:single-float-digits) ((double-float) vm:double-float-digits) #+long-float ((long-float) vm:long-float-digits) #+double-double ((double-double-float) vm:double-double-float-digits))) (defun float-radix (f) "Returns (as an integer) the radix b of its floating-point argument." (number-dispatch ((f float)) ((float) 2))) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT: (declaim (maybe-inline integer-decode-single-float integer-decode-double-float)) ;;; INTEGER-DECODE-SINGLE-DENORM -- Internal ;;; ;;; Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT. ;;; (defun integer-decode-single-denorm (x) (declare (type single-float x)) (let* ((bits (single-float-bits (abs x))) (sig (ash (ldb vm:single-float-significand-byte bits) 1)) (extra-bias 0)) (declare (type (unsigned-byte 24) sig) (type (integer 0 23) extra-bias)) (loop (unless (zerop (logand sig vm:single-float-hidden-bit)) (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values sig (- (- vm:single-float-bias) vm:single-float-digits extra-bias) (if (minusp (float-sign x)) -1 1)))) ;;; INTEGER-DECODE-SINGLE-FLOAT -- Internal ;;; ;;; Handle the single-float case of INTEGER-DECODE-FLOAT. If an infinity or ;;; NAN, error. If a denorm, call i-d-s-DENORM to handle it. ;;; (defun integer-decode-single-float (x) (declare (single-float x)) (let* ((bits (single-float-bits (abs x))) (exp (ldb vm:single-float-exponent-byte bits)) (sig (ldb vm:single-float-significand-byte bits)) (sign (if (minusp (float-sign x)) -1 1)) (biased (- exp vm:single-float-bias vm:single-float-digits))) (declare (fixnum biased)) (unless (<= exp vm:single-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((and (zerop exp) (zerop sig)) (values 0 biased sign)) ((< exp vm:single-float-normal-exponent-min) (integer-decode-single-denorm x)) (t (values (logior sig vm:single-float-hidden-bit) biased sign))))) ;;; INTEGER-DECODE-DOUBLE-DENORM -- Internal ;;; ;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so. ;;; (defun integer-decode-double-denorm (x) (declare (type double-float x)) (let* ((high-bits (double-float-high-bits (abs x))) (sig-high (ldb vm:double-float-significand-byte high-bits)) (low-bits (double-float-low-bits x)) (sign (if (minusp (float-sign x)) -1 1)) (biased (- (- vm:double-float-bias) vm:double-float-digits))) (if (zerop sig-high) (let ((sig low-bits) (extra-bias (- vm:double-float-digits 33)) (bit (ash 1 31))) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (loop (unless (zerop (logand sig bit)) (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values (ash sig (- vm:double-float-digits 32)) (truly-the fixnum (- biased extra-bias)) sign)) (let ((sig (ash sig-high 1)) (extra-bias 0)) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (loop (unless (zerop (logand sig vm:double-float-hidden-bit)) (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values (logior (ash sig 32) (ash low-bits (1+ extra-bias))) (truly-the fixnum (- biased extra-bias)) sign))))) ;;; INTEGER-DECODE-DOUBLE-FLOAT -- Internal ;;; ;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so. ;;; (defun integer-decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) (hi (double-float-high-bits abs)) (lo (double-float-low-bits abs)) (exp (ldb vm:double-float-exponent-byte hi)) (sig (ldb vm:double-float-significand-byte hi)) (sign (if (minusp (float-sign x)) -1 1)) (biased (- exp vm:double-float-bias vm:double-float-digits))) (declare (fixnum biased)) (unless (<= exp vm:double-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((and (zerop exp) (zerop sig) (zerop lo)) (values 0 biased sign)) ((< exp vm:double-float-normal-exponent-min) (integer-decode-double-denorm x)) (t (values (logior (ash (logior (ldb vm:double-float-significand-byte hi) vm:double-float-hidden-bit) 32) lo) biased sign))))) ;;; INTEGER-DECODE-LONG-DENORM -- Internal ;;; #+(and long-float x86) (defun integer-decode-long-denorm (x) (declare (type long-float x)) (let* ((high-bits (long-float-high-bits (abs x))) (sig-high (ldb vm:long-float-significand-byte high-bits)) (low-bits (long-float-low-bits x)) (sign (if (minusp (float-sign x)) -1 1)) (biased (- (- vm:long-float-bias) vm:long-float-digits))) (if (zerop sig-high) (let ((sig low-bits) (extra-bias (- vm:long-float-digits 33)) (bit (ash 1 31))) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (loop (unless (zerop (logand sig bit)) (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values (ash sig (- vm:long-float-digits 32)) (truly-the fixnum (- biased extra-bias)) sign)) (let ((sig (ash sig-high 1)) (extra-bias 0)) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (loop (unless (zerop (logand sig vm:long-float-hidden-bit)) (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) (truly-the fixnum (- biased extra-bias)) sign))))) #+double-double (defun integer-decode-double-double-float (x) (declare (type double-double-float x)) (multiple-value-bind (hi-int hi-exp sign) (integer-decode-float (double-double-hi x)) (if (zerop (double-double-lo x)) (values (ash hi-int 53) (- hi-exp 53) sign) (multiple-value-bind (lo-int lo-exp lo-sign) (integer-decode-float (double-double-lo x)) ;; We have x = 2^e1*i1 + 2^e2*i2 ;; = 2^e2*(2^(e1-e2)*i1 + i2) ;; ;; NOTE: The hi and lo parts could actually have different ;; signs, so we need to add the two parts together with the ;; right sign! (values (+ (* (* sign lo-sign) lo-int) (ash hi-int (- hi-exp lo-exp))) lo-exp sign))))) ;;; INTEGER-DECODE-LONG-FLOAT -- Internal ;;; #+(and long-float x86) (defun integer-decode-long-float (x) (declare (long-float x)) (let* ((hi (long-float-high-bits x)) (lo (long-float-low-bits x)) (exp-bits (long-float-exp-bits x)) (exp (ldb vm:long-float-exponent-byte exp-bits)) (sign (if (minusp exp-bits) -1 1)) (biased (- exp vm:long-float-bias vm:long-float-digits))) (declare (fixnum biased)) (unless (<= exp vm:long-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((and (zerop exp) (zerop hi) (zerop lo)) (values 0 biased sign)) ((< exp vm:long-float-normal-exponent-min) (integer-decode-long-denorm x)) (t (values (logior (ash hi 32) lo) biased sign))))) ;;; INTEGER-DECODE-FLOAT -- Public ;;; ;;; Dispatch to the correct type-specific i-d-f function. ;;; (defun integer-decode-float (x) "Returns three values: 1) an integer representation of the significand. 2) the exponent for the power of 2 that the significand must be multiplied by to get the actual value. This differs from the DECODE-FLOAT exponent by FLOAT-DIGITS, since the significand has been scaled to have all its digits before the radix point. 3) -1 or 1 (i.e. the sign of the argument.)" (number-dispatch ((x float)) ((single-float) (integer-decode-single-float x)) ((double-float) (integer-decode-double-float x)) #+long-float ((long-float) (integer-decode-long-float x)) #+double-double ((double-double-float) (integer-decode-double-double-float x)))) (declaim (maybe-inline decode-single-float decode-double-float)) ;;; DECODE-SINGLE-DENORM -- Internal ;;; ;;; Handle the denormalized case of DECODE-SINGLE-FLOAT. We call ;;; INTEGER-DECODE-SINGLE-DENORM and then make the result into a float. ;;; (defun decode-single-denorm (x) (declare (type single-float x)) (multiple-value-bind (sig exp sign) (integer-decode-single-denorm x) (values (make-single-float (dpb sig vm:single-float-significand-byte (dpb vm:single-float-bias vm:single-float-exponent-byte 0))) (truly-the fixnum (+ exp vm:single-float-digits)) (float sign x)))) ;;; DECODE-SINGLE-FLOAT -- Internal ;;; ;;; Handle the single-float case of DECODE-FLOAT. If an infinity or NAN, ;;; error. If a denorm, call d-s-DENORM to handle it. ;;; (defun decode-single-float (x) (declare (single-float x)) (let* ((bits (single-float-bits (abs x))) (exp (ldb vm:single-float-exponent-byte bits)) (sign (float-sign x)) (biased (truly-the single-float-exponent (- exp vm:single-float-bias)))) (unless (<= exp vm:single-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((zerop x) (values 0.0f0 biased sign)) ((< exp vm:single-float-normal-exponent-min) (decode-single-denorm x)) (t (values (make-single-float (dpb vm:single-float-bias vm:single-float-exponent-byte bits)) biased sign))))) ;;; DECODE-DOUBLE-DENORM -- Internal ;;; ;;; Like DECODE-SINGLE-DENORM, only doubly so. ;;; (defun decode-double-denorm (x) (declare (double-float x)) (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x) (values (make-double-float (dpb (logand (ash sig -32) (lognot vm:double-float-hidden-bit)) vm:double-float-significand-byte (dpb vm:double-float-bias vm:double-float-exponent-byte 0)) (ldb (byte 32 0) sig)) (truly-the fixnum (+ exp vm:double-float-digits)) (float sign x)))) ;;; DECODE-DOUBLE-FLOAT -- Public ;;; ;;; Like DECODE-SINGLE-FLOAT, only doubly so. ;;; (defun decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) (hi (double-float-high-bits abs)) (lo (double-float-low-bits abs)) (exp (ldb vm:double-float-exponent-byte hi)) (sign (float-sign x)) (biased (truly-the double-float-exponent (- exp vm:double-float-bias)))) (unless (<= exp vm:double-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((zerop x) (values 0.0d0 biased sign)) ((< exp vm:double-float-normal-exponent-min) (decode-double-denorm x)) (t (values (make-double-float (dpb vm:double-float-bias vm:double-float-exponent-byte hi) lo) biased sign))))) ;;; DECODE-LONG-DENORM -- Internal ;;; #+(and long-float x86) (defun decode-long-denorm (x) (declare (long-float x)) (multiple-value-bind (sig exp sign) (integer-decode-long-denorm x) (values (make-long-float vm:long-float-bias (ash sig -32) (ldb (byte 32 0) sig)) (truly-the fixnum (+ exp vm:long-float-digits)) (float sign x)))) ;;; DECODE-LONG-FLOAT -- Public ;;; #+(and long-float x86) (defun decode-long-float (x) (declare (long-float x)) (let* ((hi (long-float-high-bits x)) (lo (long-float-low-bits x)) (exp-bits (long-float-exp-bits x)) (exp (ldb vm:long-float-exponent-byte exp-bits)) (sign (if (minusp exp-bits) -1l0 1l0)) (biased (truly-the long-float-exponent (- exp vm:long-float-bias)))) (unless (<= exp vm:long-float-normal-exponent-max) (error (intl:gettext "Can't decode NAN or infinity: ~S.") x)) (cond ((zerop x) (values 0.0l0 biased sign)) ((< exp vm:long-float-normal-exponent-min) (decode-long-denorm x)) (t (values (make-long-float (dpb vm:long-float-bias vm:long-float-exponent-byte exp-bits) hi lo) biased sign))))) ;;; DECODE-DOUBLE-DOUBLE-FLOAT -- Public #+double-double (defun decode-double-double-float (x) (declare (type double-double-float x)) (multiple-value-bind (hi-frac hi-exp sign) (decode-float (double-double-hi x)) (values (make-double-double-float hi-frac (scale-float (double-double-lo x) (- hi-exp))) hi-exp (coerce sign 'double-double-float)))) ;;; DECODE-FLOAT -- Public ;;; ;;; Dispatch to the appropriate type-specific function. ;;; (defun decode-float (f) "Returns three values: 1) a floating-point number representing the significand. This is always between 0.5 (inclusive) and 1.0 (exclusive). 2) an integer representing the exponent. 3) -1.0 or 1.0 (i.e. the sign of the argument.)" (number-dispatch ((f float)) ((single-float) (decode-single-float f)) ((double-float) (decode-double-float f)) #+long-float ((long-float) (decode-long-float f)) #+double-double ((double-double-float) (decode-double-double-float f)))) ;;;; SCALE-FLOAT: (declaim (maybe-inline scale-single-float scale-double-float)) ;;; SCALE-FLOAT-MAYBE-UNDERFLOW -- Internal ;;; ;;; Handle float scaling where the X is denormalized or the result is ;;; denormalized or underflows to 0. ;;; (defun scale-float-maybe-underflow (x exp) (multiple-value-bind (sig old-exp) (integer-decode-float x) (let* ((digits (float-digits x)) (new-exp (+ exp old-exp digits (etypecase x (single-float vm:single-float-bias) (double-float vm:double-float-bias)))) (sign (if (minusp (float-sign x)) 1 0))) (cond ((< new-exp (etypecase x (single-float vm:single-float-normal-exponent-min) (double-float vm:double-float-normal-exponent-min))) (when (vm:current-float-trap :inexact) (error 'floating-point-inexact :operation 'scale-float :operands (list x exp))) (when (vm:current-float-trap :underflow) (error 'floating-point-underflow :operation 'scale-float :operands (list x exp))) (let ((shift (1- new-exp))) ;; Is it necessary to have this IF here? Is there any case ;; where (ash sig shift) won't return 0 when ;; shift < -(digits-1)? (if (< shift (- (1- digits))) (etypecase x (single-float (single-from-bits sign 0 0)) (double-float (double-from-bits sign 0 0))) (etypecase x (single-float (single-from-bits sign 0 (ash sig shift))) (double-float (double-from-bits sign 0 (ash sig shift))))))) (t (etypecase x (single-float (single-from-bits sign new-exp sig)) (double-float (double-from-bits sign new-exp sig)))))))) ;;; SCALE-FLOAT-MAYBE-OVERFLOW -- Internal ;;; ;;; Called when scaling a float overflows, or the oringinal float was a NaN ;;; or infinity. If overflow errors are trapped, then error, otherwise return ;;; the appropriate infinity. If a NaN, signal or not as appropriate. ;;; (defun scale-float-maybe-overflow (x exp) (cond ((float-infinity-p x) ;; Infinity is infinity, no matter how small... x) ((float-nan-p x) (when (and (float-signaling-nan-p x) (vm:current-float-trap :invalid)) (error 'floating-point-invalid-operation :operation 'scale-float :operands (list x exp))) x) (t (when (vm:current-float-trap :overflow) (error 'floating-point-overflow :operation 'scale-float :operands (list x exp))) (when (vm:current-float-trap :inexact) (error 'floating-point-inexact :operation 'scale-float :operands (list x exp))) (* (float-sign x) (etypecase x (single-float single-float-positive-infinity) (double-float double-float-positive-infinity)))))) ;;; SCALE-SINGLE-FLOAT, SCALE-DOUBLE-FLOAT -- Internal ;;; ;;; Scale a single or double float, calling the correct over/underflow ;;; functions. ;;; (defun scale-single-float (x exp) (declare (single-float x) (fixnum exp)) (let* ((bits (single-float-bits x)) (old-exp (ldb vm:single-float-exponent-byte bits)) (new-exp (+ old-exp exp))) (cond ((zerop x) x) ((or (< old-exp vm:single-float-normal-exponent-min) (< new-exp vm:single-float-normal-exponent-min)) (scale-float-maybe-underflow x exp)) ((or (> old-exp vm:single-float-normal-exponent-max) (> new-exp vm:single-float-normal-exponent-max)) (scale-float-maybe-overflow x exp)) (t (make-single-float (dpb new-exp vm:single-float-exponent-byte bits)))))) ;;; (declaim (maybe-inline scale-double-float)) (defun scale-double-float (x exp) (declare (double-float x) (fixnum exp)) (let* ((hi (double-float-high-bits x)) (lo (double-float-low-bits x)) (old-exp (ldb vm:double-float-exponent-byte hi)) (new-exp (+ old-exp exp))) (cond ((zerop x) x) ((or (< old-exp vm:double-float-normal-exponent-min) (< new-exp vm:double-float-normal-exponent-min)) (scale-float-maybe-underflow x exp)) ((or (> old-exp vm:double-float-normal-exponent-max) (> new-exp vm:double-float-normal-exponent-max)) (scale-float-maybe-overflow x exp)) (t (make-double-float (dpb new-exp vm:double-float-exponent-byte hi) lo))))) #+(and x86 long-float) (defun scale-long-float (x exp) (declare (long-float x) (fixnum exp)) (scale-float x exp)) #+double-double (defun scale-double-double-float (x exp) (declare (type double-double-float x) (fixnum exp)) (let ((hi (double-double-hi x)) (lo (double-double-lo x))) (make-double-double-float (scale-double-float hi exp) (scale-double-float lo exp)))) ;;; SCALE-FLOAT -- Public ;;; ;;; Dispatch to the correct type-specific scale-float function. ;;; (defun scale-float (f ex) "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss of precision or overflow." (number-dispatch ((f float)) ((single-float) (scale-single-float f ex)) ((double-float) (scale-double-float f ex)) #+long-float ((long-float) (scale-long-float f ex)) #+double-double ((double-double-float) (scale-double-double-float f ex)))) ;;;; Converting to/from floats: (defun float (number &optional (other () otherp)) "Converts any REAL to a float. If OTHER is not provided, it returns a SINGLE-FLOAT if NUMBER is not already a FLOAT. If OTHER is provided, the result is the same float format as OTHER." (if otherp (number-dispatch ((number real) (other float)) (((foreach rational single-float double-float #+long-float long-float #+double-double double-double-float) (foreach single-float double-float #+long-float long-float #+double-double double-double-float)) (coerce number '(dispatch-type other)))) (if (floatp number) number (coerce number 'single-float)))) (macrolet ((frob (name type) `(defun ,name (x) (number-dispatch ((x real)) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float fixnum)) (coerce x ',type)) ((bignum) (bignum-to-float x ',type)) ((ratio) (float-ratio x ',type)))))) (frob %single-float single-float) (frob %double-float double-float) #+long-float (frob %long-float long-float) #+(and nil double-double) (frob %double-double-float double-double-float)) ;; Note: There might be bootstrap issues when adding double-double ;; floats. Use the above definition if that's the case. #+double-double (defun %double-double-float (n) (typecase n (fixnum (%make-double-double-float (float n 1d0) 0d0)) (single-float (%make-double-double-float (float n 1d0) 0d0)) (double-float (%make-double-double-float (float n 1d0) 0d0)) (double-double-float n) (bignum (bignum:bignum-to-float n 'double-double-float)) (ratio (kernel::float-ratio n 'double-double-float)))) ;; Convert rational to double-double-float. The core algorithm is ;; from Richard Fateman. It was slightly modified to handle rationals ;; instead of just bignums. (defun rational-to-dd (rat) (declare (rational rat)) (let* ((p (coerce rat 'double-float)) (ans (%make-double-double-float p 0d0)) (remainder rat)) (declare (double-float p) (rational remainder) (type double-double-float ans)) ;; Once or twice? I think once is enough. (dotimes (k 1 ans) (decf remainder (rational p)) (setf p (coerce remainder 'double-float)) (setf ans (+ ans p))))) (defun float-ratio-float (x format) (let* ((signed-num (numerator x)) (plusp (plusp signed-num)) (num (if plusp signed-num (- signed-num))) (den (denominator x)) (digits (float-format-digits format)) (scale 0)) (declare (fixnum digits scale)) ;; ;; Strip any trailing zeros from the denominator and move it into the scale ;; factor (to minimize the size of the operands.) (let ((den-twos (1- (integer-length (logxor den (1- den)))))) (declare (fixnum den-twos)) (decf scale den-twos) (setq den (ash den (- den-twos)))) ;; ;; Guess how much we need to scale by from the magnitudes of the numerator ;; and denominator. We want one extra bit for a guard bit. (let* ((num-len (integer-length num)) (den-len (integer-length den)) (delta (- den-len num-len)) (shift (1+ (the fixnum (+ delta digits)))) (shifted-num (ash num shift))) (declare (fixnum delta shift)) (decf scale delta) (labels ((float-and-scale (bits) (let* ((bits (ash bits -1)) (len (integer-length bits))) (cond ((> len digits) (assert (= len (the fixnum (1+ digits)))) (multiple-value-bind (f0) (floatit (ash bits -1)) #+nil (progn (format t "1: f0, f1 = ~A ~A~%" f0 f1) (format t " scale = ~A~%" (1+ scale))) (scale-float f0 (1+ scale)))) (t (multiple-value-bind (f0) (floatit bits) #+nil (progn (format t "2: f0, f1 = ~A ~A~%" f0 f1) (format t " scale = ~A~%" scale) (format t "scale-float f0 = ~A~%" (scale-float f0 scale)) (when f1 (format t "scale-float f1 = ~A~%" (scale-float f1 (- scale 53))))) (scale-float f0 scale)))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format (single-float (single-from-bits sign vm:single-float-bias bits)) (double-float (double-from-bits sign vm:double-float-bias bits)) #+long-float (long-float (long-from-bits sign vm:long-float-bias bits)))))) (loop (multiple-value-bind (fraction-and-guard rem) (truncate shifted-num den) (let ((extra (- (integer-length fraction-and-guard) digits))) (declare (fixnum extra)) (cond ((/= extra 1) (assert (> extra 1))) ((oddp fraction-and-guard) (return (if (zerop rem) (float-and-scale (if (zerop (logand fraction-and-guard 2)) fraction-and-guard (1+ fraction-and-guard))) (float-and-scale (1+ fraction-and-guard))))) (t (return (float-and-scale fraction-and-guard))))) (setq shifted-num (ash shifted-num -1)) (incf scale))))))) ;;; FLOAT-RATIO -- Internal ;;; ;;; Convert a ratio to a float. We avoid any rounding error by doing an ;;; integer division. Accuracy is important to preserve read/print ;;; consistency, since this is ultimately how the reader reads a float. We ;;; scale the numerator by a power of two until the division results in the ;;; desired number of fraction bits, then do round-to-nearest. ;;; #+double-double (defun float-ratio (x format) (if (eq format 'double-double-float) (rational-to-dd x) (float-ratio-float x format))) #-double-double (defun float-ratio (x format) (float-ratio-float x format)) #| These might be useful if we ever have a machine w/o float/integer conversion hardware. For now, we'll use special ops that uninterruptibly frob the rounding modes & do ieee round-to-integer. ;;; %UNARY-TRUNCATE-SINGLE-FLOAT/FIXNUM -- Interface ;;; ;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE ;;; and the result is known to be a fixnum. We can avoid some generic ;;; arithmetic in this case. ;;; (defun %unary-truncate-single-float/fixnum (x) (declare (single-float x) (values fixnum)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((bits (single-float-bits x)) (exp (ldb vm:single-float-exponent-byte bits)) (frac (logior (ldb vm:single-float-significand-byte bits) vm:single-float-hidden-bit)) (shift (- exp vm:single-float-digits vm:single-float-bias))) (when (> exp vm:single-float-normal-exponent-max) (error 'floating-point-invalid-operation :operator 'truncate :operands (list x))) (if (<= shift (- vm:single-float-digits)) 0 (let ((res (ash frac shift))) (declare (type (unsigned-byte 31) res)) (if (minusp bits) (- res) res)))))) ;;; %UNARY-TRUNCATE-DOUBLE-FLOAT/FIXNUM -- Interface ;;; ;;; Double-float version of this operation (see above single op). ;;; (defun %unary-truncate-double-float/fixnum (x) (declare (double-float x) (values fixnum)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((hi-bits (double-float-high-bits x)) (exp (ldb vm:double-float-exponent-byte hi-bits)) (frac (logior (ldb vm:double-float-significand-byte hi-bits) vm:double-float-hidden-bit)) (shift (- exp (- vm:double-float-digits vm:word-bits) vm:double-float-bias))) (when (> exp vm:double-float-normal-exponent-max) (error 'floating-point-invalid-operation :operator 'truncate :operands (list x))) (if (<= shift (- vm:word-bits vm:double-float-digits)) 0 (let* ((res-hi (ash frac shift)) (res (if (plusp shift) (logior res-hi (the fixnum (ash (double-float-low-bits x) (- shift vm:word-bits)))) res-hi))) (declare (type (unsigned-byte 31) res-hi res)) (if (minusp hi-bits) (- res) res)))))) |# ;;; %UNARY-TRUNCATE -- Interface ;;; ;;; This function is called when we are doing a truncate without any funky ;;; divisor, i.e. converting a float or ratio to an integer. Note that we do ;;; *not* return the second value of truncate, so it must be computed by the ;;; caller if needed. ;;; ;;; In the float case, we pick off small arguments so that compiler can use ;;; special-case operations. We use an exclusive test, since (due to round-off ;;; error), (float most-positive-fixnum) may be greater than ;;; most-positive-fixnum. ;;; (defun %unary-truncate (number) (number-dispatch ((number real)) ((integer) number) ((ratio) (values (truncate (numerator number) (denominator number)))) (((foreach single-float double-float #+long-float long-float)) (if (< (float most-negative-fixnum number) number (float most-positive-fixnum number)) (truly-the fixnum (%unary-truncate number)) (multiple-value-bind (bits exp) (integer-decode-float number) (let ((res (ash bits exp))) (if (minusp number) (- res) res))))) #+double-double ((double-double-float) (multiple-value-bind (bits exp) (integer-decode-double-double-float number) (let ((res (ash bits exp))) (if (minusp number) (- res) res)))))) ;;; %UNARY-ROUND -- Interface ;;; ;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we ;;; can't use the round primitive, then we do our own round-to-nearest on the ;;; result of i-d-f. [Note that this rounding will really only happen with ;;; double floats, since the whole single-float fraction will fit in a fixnum, ;;; so all single-floats larger than most-positive-fixnum can be precisely ;;; represented by an integer.] ;;; (defun %unary-round (number) (flet ((round-integer (bits exp sign) (let* ((shifted (ash bits exp)) (roundup-p ;; Round if the are fraction bits (exp is ;; negative). (when (minusp exp) (let ((fraction (ldb (byte (- exp) 0) bits)) (half (ash 1 (- -1 exp)))) ;; If the fraction is less than half, then no ;; rounding. Otherwise, round up if the ;; fraction is greater than half or the ;; integer part is odd (for round-to-even). (cond ((> fraction half) t) ((< fraction half) nil) ((oddp shifted) t))))) (rounded (if roundup-p (1+ shifted) shifted))) (if (minusp sign) (- rounded) rounded)))) (number-dispatch ((number real)) ((integer) number) ((ratio) (values (round (numerator number) (denominator number)))) (((foreach single-float double-float #+long-float long-float)) (if (< (float most-negative-fixnum number) number (float most-positive-fixnum number)) (truly-the fixnum (%unary-round number)) (multiple-value-bind (bits exp sign) (integer-decode-float number) (round-integer bits exp sign)))) #+double-double ((double-double-float) (multiple-value-bind (bits exp sign) (integer-decode-float number) (round-integer bits exp sign)))))) (declaim (maybe-inline %unary-ftruncate/single-float %unary-ftruncate/double-float)) ;; %UNARY-FTRUNCATE/SINGLE-FLOAT ;; ;; Basically the same as ftruncate, but specialized to handle only ;; single-floats and to only return the first value. (defun %unary-ftruncate/single-float (x) (declare (single-float x) (optimize (speed 3) (safety 0))) ;; We diddle the bits directly to truncate the number to reduce ;; consing. #+x87 (let* ((bits (kernel:single-float-bits x)) (exp (ldb vm:single-float-exponent-byte bits)) (biased (truly-the kernel:single-float-exponent (- exp vm:single-float-bias)))) (declare (type (signed-byte 32) bits)) ;; At this point, we have the number represented as ;; ;; x = sign * 2^exp * frac ;; ;; where 0.5 <= frac < 1.0 ;; ;; So if the exp <= 0, |x| < 1 and we know the result is 0. ;; ;; If exp >= (float-digits x), we know that all of the bits ;; in the fraction are integer bits, so the result is x. ;; ;; For everything else, some of the bits in frac are ;; fractional. Figure which ones they are and set them to ;; zero. ;; (cond ((> exp vm:single-float-normal-exponent-max) ;; Infinity or NaN. Convert NaN to quiet NaN. (let ((signif (ldb vm:single-float-significand-byte bits))) (if (zerop signif) ;; Infinity x ;; NaN. Convert to quiet Nan (make-single-float (logior bits vm:single-float-trapping-nan-bit))))) ((<= biased 0) ;; Number is less than 1. IEEE 754 says it should have the ;; same sign. Make it so. (* x 0f0)) ((>= biased (float-digits x)) ;; Number is an integer x) (t ;; Somewhere in between. Zap the bits that ;; represent the fraction part. (let ((frac-bits (- (float-digits x) biased))) (setf bits (logandc2 bits (- (ash 1 frac-bits) 1))) (kernel:make-single-float bits))))) ;; We have a fast fround, so use that and fix up the result to ;; truncate. #-x87 (let ((r (%unary-fround/single-float x))) (if (> (abs r) (abs x)) (if (> r 0) (- r 1) (+ r 1)) r))) ;; %UNARY-FTRUNCATE/DOUBLE-FLOAT ;; ;; Like %UNARY-FTRUNCATE/SINGLE-FLOAT, except for double-float. (defun %unary-ftruncate/double-float (x) (declare (double-float x) (optimize (speed 3) (safety 0))) #+x87 (let* ((hi (kernel:double-float-high-bits x)) (lo (kernel:double-float-low-bits x)) (exp (ldb vm:double-float-exponent-byte hi)) (biased (truly-the kernel:double-float-exponent (- exp vm:double-float-bias)))) (declare (type (signed-byte 32) hi) (type (unsigned-byte 32) lo)) (cond ((> exp vm:double-float-normal-exponent-max) ;; Infinity or NaN. Convert NaN to quiet NaN. (if (and (zerop (ldb vm:double-float-significand-byte hi)) (zerop lo)) ;; Infinity x ;; NaN. Convert to quiet NaN (make-double-float (logior hi vm:double-float-trapping-nan-bit) lo))) ((<= biased 0) ;; Number is less than 1. IEEE 754 says it should have the ;; same sign. Make it so. (* x 0d0)) ((>= biased (float-digits x)) ;; Number is an integer x) (t ;; Somewhere in between. Zap the bits that ;; represent the fraction part. (let ((frac-bits (- (float-digits x) biased))) (cond ((< frac-bits 32) (setf lo (logandc2 lo (- (ash 1 frac-bits) 1)))) (t (setf lo 0) (setf hi (logandc2 hi (- (ash 1 (- frac-bits 32)) 1))))) (kernel:make-double-float hi lo))))) ;; We have a fast fround, so use that and fix up the result to ;; truncate. #-x87 (let ((r (%unary-fround/double-float x))) (if (> (abs r) (abs x)) (if (> r 0) (- r 1) (+ r 1)) r))) #+double-double (defun %unary-ftruncate/double-double-float (x) ;; We should do something like what we do for double-double-float, ;; but I'm lazy right now. (coerce (truncate x) 'double-double-float)) ;;; %UNARY-FTRUNCATE -- Interface ;;; ;;; This function is called when we are doing an ftruncate without any ;;; funky divisor. Note that we do *not* return the second value of ;;; truncate, so it must be computed by the caller if needed. ;;; ;;; In the float case, we pick off small arguments so that compiler ;;; can use special-case operations. We use an exclusive test, since ;;; (due to round-off error), (float most-positive-signed-byte-32) may ;;; be greater than most-positive-signed-byte-32. We chose this ;;; because %unary-truncate can be optimized when the result is known ;;; to be a (signed-byte 32). ;;; (defun %unary-ftruncate (number) (number-dispatch ((number real)) ((integer) (float number)) ((ratio) (float (truncate (numerator number) (denominator number)))) ((single-float) (%unary-ftruncate/single-float number)) ((double-float) (%unary-ftruncate/double-float number)) #+double-double ((double-double-float) (%unary-ftruncate/double-double-float number)))) ;; %UNARY-FROUND not implemented for x87. I think there are potential ;; roundoff problems due to the 80-bit FPU registers. #-x87 (progn (declaim (inline %unary-fround/single-float %unary-fround/double-float)) ;; %UNARY-FROUND/DOUBLE-FLOAT ;; ;; Basically the same as fround, but specialized to handle only ;; double-floats and to return the first value. This is the algorithm ;; given by Anton Ertl in comp.arch.arithmetic, Oct 26, 2002. (defun %unary-fround/double-float (x) (declare (double-float x)) (let ((const (scale-float 1d0 53))) (cond ((> x 0) (+ (- x const) const)) ((< x 0) (- (+ x const) const)) (t x)))) ;; %UNARY-FROUND/SINLGE-FLOAT ;; ;; Same as %UNARY-FROUND/DOUBLE-FLOAT, except specialized for single-float. (defun %unary-fround/single-float (x) (declare (single-float x)) (let ((const (scale-float 1f0 24))) (cond ((> x 0) (+ (- x const) const)) ((< x 0) (- (+ x const) const)) (t x)))) ;;; %UNARY-FROUND -- Interface ;;; ;;; This function is called when we are doing an fround without any ;;; funky divisor. Note that we do *not* return the second value of ;;; round, so it must be computed by the caller if needed. ;;; (defun %unary-fround (number) (number-dispatch ((number real)) ((integer) (float number)) ((ratio) (float (round (numerator number) (denominator number)))) ((single-float) (%unary-fround/single-float number)) ((double-float) (%unary-fround/double-float number)))) ) ; not x87 (defun rational (x) "RATIONAL produces a rational number for any real numeric argument. This is more efficient than RATIONALIZE, but it assumes that floating-point is completely accurate, giving a result that isn't as pretty." (number-dispatch ((x real)) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float)) (multiple-value-bind (bits exp) (integer-decode-float x) (if (eql bits 0) 0 (let* ((int (if (minusp x) (- bits) bits)) (digits (float-digits x)) (ex (+ exp digits))) (if (minusp ex) (integer-/-integer int (ash 1 (+ digits (- ex)))) (integer-/-integer (ash int ex) (ash 1 digits))))))) ((rational) x))) #+nil (defun rationalize (x) "Converts any REAL to a RATIONAL. Floats are converted to a simple rational representation exploiting the assumption that floats are only accurate to their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: (= x (float (rationalize x) x))" (number-dispatch ((x real)) (((foreach single-float double-float #+long-float long-float)) ;; Thanks to Kim Fateman, who stole this function rationalize-float ;; from macsyma's rational. Macsyma'a rationalize was written ;; by the legendary Gosper (rwg). Gosper is now working for Symbolics. ;; Guy Steele said about Gosper, "He has been called the ;; only living 17th century mathematician and is also the best ;; pdp-10 hacker I know." So, if you can understand or debug this ;; code you win big. (cond ((minusp x) (- (rationalize (- x)))) ((zerop x) 0) (t (let ((eps (etypecase x (single-float single-float-epsilon) (double-float double-float-epsilon) #+long-float (long-float long-float-epsilon))) (y ()) (a ())) (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x))))) (num (setq a (truncate x)) (+ (* (setq a (truncate y)) num) onum)) (den 1 (+ (* a den) oden)) (onum 1 num) (oden 0 den)) ((or (= xx (float a x)) (and (not (zerop den)) (not (> (abs (/ (- x (/ (float num x) (float den x))) x)) eps)))) (integer-/-integer num den)) (declare ((dispatch-type x) xx))))))) ((rational) x))) ;;; RATIONALIZE -- Public ;;; ;;; The algorithm here is the method described in CLISP. Bruno Haible has ;;; graciously given permission to use this algorithm. He says, "You can use ;;; it, if you present the following explanation of the algorithm." ;;; ;;; Algorithm (recursively presented): ;;; If x is a rational number, return x. ;;; If x = 0.0, return 0. ;;; If x < 0.0, return (- (rationalize (- x))). ;;; If x > 0.0: ;;; Call (integer-decode-float x). It returns a m,e,s=1 (mantissa, ;;; exponent, sign). ;;; If m = 0 or e >= 0: return x = m*2^e. ;;; Search a rational number between a = (m-1/2)*2^e and b = (m+1/2)*2^e ;;; with smallest possible numerator and denominator. ;;; Note 1: If m is a power of 2, we ought to take a = (m-1/4)*2^e. ;;; But in this case the result will be x itself anyway, regardless of ;;; the choice of a. Therefore we can simply ignore this case. ;;; Note 2: At first, we need to consider the closed interval [a,b]. ;;; but since a and b have the denominator 2^(|e|+1) whereas x itself ;;; has a denominator <= 2^|e|, we can restrict the seach to the open ;;; interval (a,b). ;;; So, for given a and b (0 < a < b) we are searching a rational number ;;; y with a <= y <= b. ;;; Recursive algorithm fraction_between(a,b): ;;; c := (ceiling a) ;;; if c < b ;;; then return c ; because a <= c < b, c integer ;;; else ;;; ; a is not integer (otherwise we would have had c = a < b) ;;; k := c-1 ; k = floor(a), k < a < b <= k+1 ;;; return y = k + 1/fraction_between(1/(b-k), 1/(a-k)) ;;; ; note 1 <= 1/(b-k) < 1/(a-k) ;;; ;;; You can see that we are actually computing a continued fraction expansion. ;;; ;;; Algorithm (iterative): ;;; If x is rational, return x. ;;; Call (integer-decode-float x). It returns a m,e,s (mantissa, ;;; exponent, sign). ;;; If m = 0 or e >= 0, return m*2^e*s. (This includes the case x = 0.0.) ;;; Create rational numbers a := (2*m-1)*2^(e-1) and b := (2*m+1)*2^(e-1) ;;; (positive and already in lowest terms because the denominator is a ;;; power of two and the numerator is odd). ;;; Start a continued fraction expansion ;;; p[-1] := 0, p[0] := 1, q[-1] := 1, q[0] := 0, i := 0. ;;; Loop ;;; c := (ceiling a) ;;; if c >= b ;;; then k := c-1, partial_quotient(k), (a,b) := (1/(b-k),1/(a-k)), ;;; goto Loop ;;; finally partial_quotient(c). ;;; Here partial_quotient(c) denotes the iteration ;;; i := i+1, p[i] := c*p[i-1]+p[i-2], q[i] := c*q[i-1]+q[i-2]. ;;; At the end, return s * (p[i]/q[i]). ;;; This rational number is already in lowest terms because ;;; p[i]*q[i-1]-p[i-1]*q[i] = (-1)^i. ;;; (defun rationalize (x) "Converts any REAL to a RATIONAL. Floats are converted to a simple rational representation exploiting the assumption that floats are only accurate to their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: (= x (float (rationalize x) x))" (number-dispatch ((x real)) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float)) ;; This is a fairly straigtforward implementation of the iterative ;; algorithm above. (multiple-value-bind (frac expo sign) (integer-decode-float x) (cond ((or (zerop frac) (>= expo 0)) (if (minusp sign) (- (ash frac expo)) (ash frac expo))) (t ;; expo < 0 and (2*m-1) and (2*m+1) are coprime to 2^(1-e), ;; so build the fraction up immediately, without having to do ;; a gcd. (let ((a (build-ratio (- (* 2 frac) 1) (ash 1 (- 1 expo)))) (b (build-ratio (+ (* 2 frac) 1) (ash 1 (- 1 expo)))) (p0 0) (q0 1) (p1 1) (q1 0)) (do ((c (ceiling a) (ceiling a))) ((< c b) (let ((top (+ (* c p1) p0)) (bot (+ (* c q1) q0))) (build-ratio (if (minusp sign) (- top) top) bot))) (let* ((k (- c 1)) (p2 (+ (* k p1) p0)) (q2 (+ (* k q1) q0))) (psetf a (/ (- b k)) b (/ (- a k))) (setf p0 p1 q0 q1 p1 p2 q1 q2)))))))) ((rational) x))) cmucl-21a/src/code/foreign-linkage.lisp000066400000000000000000000055511260377556400202220ustar00rootroot00000000000000(in-package "LISP") (intl:textdomain "cmucl") (sys:register-lisp-runtime-feature :linkage-table) ;;; This gets created by genesis and lives in the static area. (defvar *linkage-table-data*) ;;; Key is symbol name, value is index into *linkage-table-data* (defvar *foreign-linkage-symbols* (make-hash-table :test #'equal)) ;;; Very unlispy layout of the *linkage-table-data*: ;;; symbol name ;;; type - a fixnum, 1 = code, 2 = data ;;; library list - the library list at the time the symbol is registered. (defconstant +linkage-data-entry-size+ 3) (defun add-linkage-data (symbol-name type table loaded-libs) (let ((sym-type (ecase type (:code 1) (:data 2))) (entry-num (/ (fill-pointer table) +linkage-data-entry-size+))) (vector-push-extend symbol-name table) (vector-push-extend sym-type table) (vector-push-extend loaded-libs table) entry-num)) (defun foreign-linkage-entry (entry-num) (let ((index (* entry-num +linkage-data-entry-size+))) (values (aref *linkage-table-data* index) (ecase (aref *linkage-table-data* (1+ index)) (1 :code) (2 :data)) (aref *linkage-table-data* (+ index 2))))) (defun foreign-linkage-symbols () (/ (length *linkage-table-data*) +linkage-data-entry-size+)) (defun add-foreign-linkage (symbol-name type table linkage-hash make-linkage-stub-p) (let ((entry-num (add-linkage-data symbol-name type table (if make-linkage-stub-p system::*global-table* nil)))) (when make-linkage-stub-p #-building-cross-compiler (let ((result (alien:alien-funcall (alien:extern-alien "os_link_one_symbol" (alien:function c-call:int c-call:long)) entry-num))) (when (zerop result) (error (intl:gettext "~A is not defined as a foreign symbol") symbol-name)))) (setf (gethash symbol-name linkage-hash) entry-num) entry-num)) ;;; Add a foreign linkage entry if none exists. ;;; ;;; If a linkage table is passed in it's assumed this is genesis and ;;; we don't want to make an actual stub or entry in the table space. (defun register-foreign-linkage (symbol-name type &optional (table *linkage-table-data* tablep) (linkage-hash *foreign-linkage-symbols*)) (let ((entry-num (gethash symbol-name linkage-hash))) (if entry-num entry-num (add-foreign-linkage symbol-name type table linkage-hash (not tablep))))) ;;; At world build time, build the linkage hash table (defun foreign-linkage-init () ;; Sigh, would like to use LENGTH instead of FILL-POINTER but it's ;; not generic enough during the init process! ;; XXX I'm not sure that comment is true... (loop for i from 0 below (/ (fill-pointer *linkage-table-data*) +linkage-data-entry-size+) do (setf (gethash (aref *linkage-table-data* (* i +linkage-data-entry-size+)) *foreign-linkage-symbols*) i))) cmucl-21a/src/code/foreign.lisp000066400000000000000000001056511260377556400166140ustar00rootroot00000000000000;;; -*- Package: SYSTEM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/foreign.lisp $") ;;; ;;; ********************************************************************** ;;; (in-package "SYSTEM") (intl:textdomain "cmucl") (in-package "ALIEN") (export '(load-foreign)) (in-package "SYSTEM") (import 'alien:load-foreign) #+sparc (defconstant foreign-segment-start #xe0000000) #+sparc (defconstant foreign-segment-size #x00100000) #+hppa (defconstant foreign-segment-start #x10C00000) #+hppa (defconstant foreign-segment-size #x00400000) #+(and bsd x86) (defconstant foreign-segment-start #x0E000000) #+(and bsd x86) (defconstant foreign-segment-size #x02000000) (defvar *previous-linked-object-file* nil) #-(or linux bsd svr4 irix) (defvar *foreign-segment-free-pointer* foreign-segment-start) (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C")) (let ((code (char-code #\A))) (loop (let ((name (format nil base (unix:unix-getpid) (code-char code)))) (multiple-value-bind (fd errno) (unix:unix-open name (logior unix:o_wronly unix:o_creat unix:o_excl) #o666) (cond ((not (null fd)) (unix:unix-close fd) (return name)) ((not (= errno unix:eexist)) (error (intl:gettext "Could not create temporary file ~S: ~A") name (unix:get-unix-error-msg errno))) ((= code (char-code #\Z)) (setf code (char-code #\a))) ((= code (char-code #\z)) (return nil)) (t (incf code)))))))) #+(or (and FreeBSD (not elf)) (and sparc (not svr4))) (alien:def-alien-type exec (alien:struct nil (magic c-call:unsigned-long) (text c-call:unsigned-long) (data c-call:unsigned-long) (bss c-call:unsigned-long) (syms c-call:unsigned-long) (entry c-call:unsigned-long) (trsize c-call:unsigned-long) (drsize c-call:unsigned-long))) #-(or linux bsd svr4) (defun allocate-space-in-foreign-segment (bytes) (let* ((pagesize-1 (1- (get-page-size))) (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1)) (addr (int-sap *foreign-segment-free-pointer*)) (new-ptr (+ *foreign-segment-free-pointer* memory-needed))) (when (> new-ptr (+ foreign-segment-start foreign-segment-size)) (error (intl:gettext "Not enough memory left."))) (setf *foreign-segment-free-pointer* new-ptr) (allocate-system-memory-at addr memory-needed) addr)) ;;; ELF object file loading. Note that the conditionalization is ;;; assuming that all of Linux/x86, Linux/Alpha, FreeBSD/x86, ;;; OpenBSD/x86, and Solaris ports support ELF. ;;; ;;; The following definitions are taken from ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h. ;;; #+(or linux (and bsd (not darwin)) svr4) (progn (alien:def-alien-type elf-address (alien:unsigned 32)) (alien:def-alien-type elf-half-word (alien:unsigned 16)) (alien:def-alien-type elf-offset (alien:unsigned 32)) (alien:def-alien-type elf-signed-word (alien:integer 32)) (alien:def-alien-type elf-word (alien:unsigned 32)) (alien:def-alien-type elf-size (alien:unsigned 32)) (alien:def-alien-type eheader ;;"Elf file header." (alien:struct nil (elf-ident (alien:array (alien:unsigned 8) 16)) (elf-type elf-half-word) (elf-machine elf-half-word) (elf-version elf-word) (elf-entry elf-address) (elf-program-header-offset elf-offset) (elf-section-header-offset elf-offset) (elf-flags elf-word) (elf-header-size elf-half-word) (elf-program-header-entry-size elf-half-word) (elf-program-header-count elf-half-word) (elf-section-header-entry-size elf-half-word) (elf-section-header-count elf-half-word) (elf-section-name-strings elf-half-word))) ;; Indices into the elf-ident array, as per SVR4 ABI (defconstant ei-mag0 0) ; Magic number, byte 0 (defconstant ei-mag1 1) ; Magic number, byte 1 (defconstant ei-mag2 2) ; Magic number, byte 2 (defconstant ei-mag3 3) ; Magic number, byte 3 (defconstant ei-class 4) ; class of machine (defconstant ei-data 5) ; data format (defconstant ei-version 6) ; ELF format version (defconstant ei-osabi 7) ; Operating system / ABI identification (defconstant ei-abiversion 8) ; ABI version (defconstant ei-pad 9) ; Start of padding (defconstant ei-nident 16) ; Size of elf-ident array ;; values for elf-type (defconstant et-relocatable 1) (defconstant et-executable 2) (defconstant et-shared-object 3) (defconstant et-core-file 4) ;; values for elf-ident[ei-osabi] (defconstant elfosabi-sysv 0) (defconstant elfosabi-hpux 1) (defconstant elfosabi-netbsd 2) (defconstant elfosabi-linux 3) (defconstant elfosabi-hurd 4) (defconstant elfosabi-86open 5) (defconstant elfosabi-solaris 6) (defconstant elfosabi-monterey 7) (defconstant elfosabi-irix 8) (defconstant elfosabi-freebsd 9) (defconstant elfosabi-tru64 10) (defconstant elfosabi-modesto 11) (defconstant elfosabi-openbsd 12) (defconstant elfosabi-arm 97) (defconstant elfosabi-standalone 255) (alien:def-alien-type pheader ;;"Program header." (alien:struct nil (p-type elf-word) ; Entry type. (p-offset elf-offset) ; File offset of contents. (p-virtual-address elf-address) ; Virtual address in mem. image. (p-physical-address elf-address) ; Physical address (not used). (p-file-size elf-size) ; Size of contents in file. (p-memory-size elf-size) ; Size of contents in memory. (p-flags elf-word) ; Access permission flags. (p-alignment elf-size))) ; Alignment in memory and file. (defconstant +elf-magic+ (make-array 4 :element-type '(unsigned-byte 8) :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F (defun elf-p (h) _N"Make sure the header starts with the ELF magic value." (dotimes (i 4 t) (unless (= (alien:deref h i) (aref +elf-magic+ i)) (return nil)))) (defun elf-osabi (h) _N"Return the `osabi' field in the padding of the ELF file." (alien:deref h ei-osabi)) (defun elf-osabi-name (id) (cond ((eql id elfosabi-sysv) "Unix System V ABI") ((eql id elfosabi-hpux) "HP-UX") ((eql id elfosabi-netbsd) "NetBSD") ((eql id elfosabi-linux) "Linux") ((eql id elfosabi-hurd) "GNU/Hurd") ((eql id elfosabi-86open) "86Open common IA32 ABI") ((eql id elfosabi-solaris) "Solaris") ((eql id elfosabi-monterey) "Monterey") ((eql id elfosabi-irix) "IRIX") ((eql id elfosabi-freebsd) "FreeBSD") ((eql id elfosabi-tru64) "Tru64 Unix") ((eql id elfosabi-modesto) "Novell Modesto") ((eql id elfosabi-openbsd) "OpenBSD") ((eql id elfosabi-arm) "ARM") ((eql id elfosabi-standalone) "Standalone/Embedded") (t (format nil "Unknown ABI (~D)" id)))) (defun elf-executable-p (n) _N"Given a file type number, determine whether the file is executable." (= n et-executable)) (defun file-shared-library-p (pathname) (with-open-file (obj pathname :direction :input :element-type '(unsigned-byte 8)) (let ((fd (lisp::fd-stream-fd obj))) (alien:with-alien ((header eheader)) (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes)) (when (elf-p (alien:slot header 'elf-ident)) (eql et-shared-object (alien:slot header 'elf-type))))))) ) ;; #+(or linux (and bsd (not darwin)) svr4) ;; Darwin loading of foreign code. This uses the dlopen shims and thus ;; appears like ELF to the rest of the code in this file. However testing ;; for shared libs obviously needs to test for Mach-O dylibs, and not ;; ELF shared libraries... #+darwin (progn (alien:def-alien-type machheader (alien:struct nil (magic (alien:unsigned 32)) (cputype (alien:signed 32)) (cpusubtype (alien:signed 32)) (filetype (alien:unsigned 32)) (ncmds (alien:unsigned 32)) (sizeofcmds (alien:unsigned 32)) (flags (alien:unsigned 32)))) ;; values for magic (defconstant mh-magic #xfeedface) ;; values for filetype (defconstant mh-object #x1) (defconstant mh-execute #x2) (defconstant mh-fvmlib #x3) (defconstant mh-core #x4) (defconstant mh-preload #x5) (defconstant mh-dylib #x6) (defconstant mh-dylinker #x7) (defconstant mh-bundle #x8) (defconstant mh-dylib-stub #x9) ;;; Support for loading multi-arch ("fat") shared libraries. (alien:def-alien-type fat-header (alien:struct nil (magic (alien:unsigned 32)) (nfat-arch (alien:unsigned 32)))) (alien:def-alien-type fat-arch (alien:struct nil (cputype (alien:signed 32)) (cpusubtype (alien:signed 32)) (offset (alien:unsigned 32)) (size (alien:unsigned 32)) (align (alien:unsigned 32)))) (defconstant fat-header-magic #xcafebabe) (defun mach-o-p (h) _N"Make sure the header starts with the mach-o magic value." (eql (alien:slot h 'magic) mh-magic)) ;;; Read an unsigned 32-bit big-endian number from STREAM. (defun read-u32-be (stream) (let ((n 0)) (setf (ldb (byte 8 24) n) (read-byte stream)) (setf (ldb (byte 8 16) n) (read-byte stream)) (setf (ldb (byte 8 8) n) (read-byte stream)) (setf (ldb (byte 8 0) n) (read-byte stream)) n)) ;;; Read the 32-bit magic number from STREAM then rewind it. (defun read-object-file-magic (stream) (let ((pos (file-position stream))) (prog1 (read-u32-be stream) (file-position stream pos)))) ;;; XXX For a Darwin/x86 port, these functions will need to swap the ;;; byte order of the structure members. Apple's documentation states ;;; that all the fields of FAT-HEADER and FAT-ARCH are big-endian. (defun read-mach-header (stream sap) (unix:unix-read (lisp::fd-stream-fd stream) sap (alien:alien-size machheader :bytes))) (defun read-fat-header (stream sap) (unix:unix-read (lisp::fd-stream-fd stream) sap (alien:alien-size fat-header :bytes))) (defun read-fat-arch (stream sap) (unix:unix-read (lisp::fd-stream-fd stream) sap (alien:alien-size fat-arch :bytes))) ;;; Return a list of offsets in STREAM which contain Mach-O headers. ;;; For single-architecture binaries, this will return (0), emulating ;;; the previous behavior of loading the header from the start of the ;;; file. For fat binaries, there will be one offset in the result ;;; list for each architecture present in the file. (defun read-mach-header-offsets (stream) (let ((magic (read-object-file-magic stream))) (cond ((eql magic mh-magic) (list 0)) ((eql magic fat-header-magic) (alien:with-alien ((fat-header fat-header) (fat-arch fat-arch)) (read-fat-header stream (alien:alien-sap fat-header)) (loop for i from 0 below (alien:slot fat-header 'nfat-arch) do (read-fat-arch stream (alien:alien-sap fat-arch)) collect (alien:slot fat-arch 'offset)))) (t nil)))) ;;; Return true if the Mach-O HEADER represents a shared library. (defun shared-mach-header-p (header) (and (eql (alien:slot header 'magic) mh-magic) (or (eql (alien:slot header 'filetype) mh-dylib) (eql (alien:slot header 'filetype) mh-bundle)))) (defun file-shared-library-p (pathname) (with-open-file (obj pathname :direction :input :element-type '(unsigned-byte 8)) (let ((offsets (read-mach-header-offsets obj))) (when offsets (alien:with-alien ((header machheader)) (loop for offset in offsets do (file-position obj offset) (read-mach-header obj (alien:alien-sap header)) thereis (shared-mach-header-p header))))))) ) ; #+darwin ;; "old-style" loading of foreign code. This involves calling a ;; platform-specific script that is installed as ;; library:load-foreign.csh to convert the object files into a form ;; that is suitable for being stuffed into memory at runtime. #-(or linux bsd svr4) (progn (defun load-object-file (name) ;; NAME designates a tempory file created by ld via "load-foreign.csh". ;; Its contents are in a form suitable for stuffing into memory for ;; execution. This function extracts the location and size of the ;; relevant bits and reads them into memory. #|| library:load-foreign.csh #!/bin/csh -fx ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-] if ($status != 0) exit 1 nm -gp $argv[3] > $argv[4] if ($status != 0) exit 2 exit 0 ||# (format t (intl:gettext ";;; Loading object file...~%")) (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) (unless fd (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno))) (unwind-protect (alien:with-alien ((header eheader)) (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes)) (unless (elf-p (alien:slot header 'elf-ident)) (error (format nil (intl:gettext "~A is not an ELF file.") name))) (let ((osabi (elf-osabi (alien:slot header 'elf-ident))) (expected-osabi #+NetBSD elfosabi-netbsd #+FreeBSD elfosabi-freebsd)) (unless (= osabi expected-osabi) (error (intl:gettext "~A is not a ~A executable, it's a ~A executable.") name (elf-osabi-name expected-osabi) (elf-osabi-name osabi)))) (unless (elf-executable-p (alien:slot header 'elf-type)) (error (format nil (intl:gettext "~A is not executable.") name))) (alien:with-alien ((program-header pheader)) (unix:unix-read fd (alien:alien-sap program-header) (alien:alien-size pheader :bytes)) (let* ((addr (system::allocate-space-in-foreign-segment (alien:slot program-header 'p-memory-size)))) (unix:unix-lseek fd (alien:slot program-header 'p-offset) unix:l_set) (unix:unix-read fd addr (alien:slot program-header 'p-file-size))))) (unix:unix-close fd)))) (defun parse-symbol-table (name) _N"Parse symbol table file created by load-foreign script. Modified to skip undefined symbols which don't have an address." (format t (intl:gettext ";;; Parsing symbol table...~%")) (let ((symbol-table (make-hash-table :test #'equal))) (with-open-file (file name) (loop (let ((line (read-line file nil nil))) (unless line (return)) (unless (eql (aref line 0) #\space) ; Skip undefined symbols.... (let* ((symbol (subseq line 11)) (address (parse-integer line :end 8 :radix 16)) (kind (aref line 9)) ; filter out .o file names (old-address (gethash symbol lisp::*foreign-symbols*))) (unless (or (null old-address) (= address old-address) (char= kind #\F)) (warn "~S moved from #x~8,'0X to #x~8,'0X.~%" symbol old-address address)) (setf (gethash symbol symbol-table) address)))))) (setf lisp::*foreign-symbols* symbol-table))) ) ;; #-(or linux bsd svr4) ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested ;;; for correct file format so it may croak if ld fails to produce the ;;; expected results. It is probably good enough for now. #+(or (and FreeBSD (not ELF)) (and sparc (not svr4))) (defun load-object-file (name) (format t (intl:gettext ";;; Loading object file...~%")) (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) (unless fd (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno))) (unwind-protect (alien:with-alien ((header exec)) (unix:unix-read fd (alien:alien-sap header) (alien:alien-size exec :bytes)) (let* ((len-of-text-and-data (+ (alien:slot header 'text) (alien:slot header 'data))) (memory-needed (+ len-of-text-and-data (alien:slot header 'bss))) (addr (allocate-space-in-foreign-segment memory-needed))) (unix:unix-read fd addr len-of-text-and-data))) (unix:unix-close fd)))) #+hppa (alien:def-alien-type nil (alien:struct sys_clock (secs c-call:unsigned-int) (nanosecs c-call:unsigned-int))) #+hppa (alien:def-alien-type nil (alien:struct header (system_id c-call:short) (a_magic c-call:short) (version_id c-call:unsigned-int) (file_time (alien:struct sys_clock)) (entry_space c-call:unsigned-int) (entry_subspace c-call:unsigned-int) (entry_offset c-call:unsigned-int) (aux_header_location c-call:unsigned-int) (aux_header_size c-call:unsigned-int) (som_length c-call:unsigned-int) (presumed_dp c-call:unsigned-int) (space_location c-call:unsigned-int) (space_total c-call:unsigned-int) (subspace_location c-call:unsigned-int) (subspace_total c-call:unsigned-int) (loader_fixup_location c-call:unsigned-int) (loader_fixup_total c-call:unsigned-int) (space_strings_location c-call:unsigned-int) (space_strings_size c-call:unsigned-int) (init_array_location c-call:unsigned-int) (init_array_total c-call:unsigned-int) (compiler_location c-call:unsigned-int) (compiler_total c-call:unsigned-int) (symbol_location c-call:unsigned-int) (symbol_total c-call:unsigned-int) (fixup_request_location c-call:unsigned-int) (fixup_request_total c-call:unsigned-int) (symbol_strings_location c-call:unsigned-int) (symbol_strings_size c-call:unsigned-int) (unloadable_sp_location c-call:unsigned-int) (unloadable_sp_size c-call:unsigned-int) (checksum c-call:unsigned-int))) #+hppa (alien:def-alien-type nil (alien:struct aux_id #| (mandatory c-call:unsigned-int 1) (copy c-call:unsigned-int 1) (append c-call:unsigned-int 1) (ignore c-call:unsigned-int 1) (reserved c-call:unsigned-int 12) (type c-call:unsigned-int 16) |# (dummy c-call:unsigned-int) (length c-call:unsigned-int))) #+hppa (alien:def-alien-type nil (alien:struct som_exec_auxhdr (som_auxhdr (alien:struct aux_id)) (exec_tsize c-call:long) (exec_tmem c-call:long) (exec_tfile c-call:long) (exec_dsize c-call:long) (exec_dmem c-call:long) (exec_dfile c-call:long) (exec_bsize c-call:long) (exec_entry c-call:long) (exec_flags c-call:long) (exec_bfill c-call:long))) #+hppa (alien:def-alien-routine ("bzero" unix-bzero) c-call:void (s alien:system-area-pointer) (n c-call:unsigned-long)) #+hppa (defconstant reloc-magic #x106) #+hppa (defconstant cpu-pa-risc1-0 #x20b) #+hppa (defconstant cpu-pa-risc1-1 #x210) #+hppa (defconstant cpu-pa-risc-max #x2ff) #+hppa (defun load-object-file (name) (format t (intl:gettext ";;; Loading object file...~%")) (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0) (unless fd (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno))) (unwind-protect (alien:with-alien ((header (alien:struct som_exec_auxhdr))) (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes) unix:l_set) (unix:unix-read fd (alien:alien-sap header) (alien:alien-size (alien:struct som_exec_auxhdr) :bytes)) (let* ((tmem (alien:slot header 'exec_tmem)) (tsize (alien:slot header 'exec_tsize)) (dmem (alien:slot header 'exec_dmem)) (dsize (alien:slot header 'exec_dsize)) (bsize (alien:slot header 'exec_bsize)) (memory-needed (+ tsize dsize bsize (* 2 4096))) (addr (allocate-space-in-foreign-segment memory-needed))) (unix-bzero addr memory-needed) ;force valid (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set) (unix:unix-read fd (system:int-sap tmem) tsize) (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set) (unix:unix-read fd (system:int-sap dmem) dsize) (unix-bzero (system:int-sap (+ dmem dsize)) bsize) ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%" ;; tmem tsize dmem dsize bsize) ;;(format t "tfile ~X dfile ~X~%" ;; (alien:slot header 'exec_tfile) ;; (alien:slot header 'exec_dfile)) (alien:alien-funcall (alien:extern-alien "sanctify_for_execution" (alien:function c-call:void alien:system-area-pointer c-call:unsigned-long)) addr (+ (- dmem tmem) dsize bsize)) )) (unix:unix-close fd)))) #-(or linux bsd solaris irix) (progn (defun parse-symbol-table (name) (format t (intl:gettext ";;; Parsing symbol table...~%")) (let ((symbol-table (make-hash-table :test #'equal))) (with-open-file (file name) (loop (let ((line (read-line file nil nil))) (unless line (return)) (let* ((symbol (subseq line 11)) (address (parse-integer line :end 8 :radix 16)) #+BSD (kind (aref line 9)) ; filter out .o file names (old-address (gethash symbol lisp::*foreign-symbols*))) (unless (or (null old-address) (= address old-address) #+BSD (char= kind #\F)) (warn "~S moved from #x~8,'0X to #x~8,'0X.~%" symbol old-address address)) (setf (gethash symbol symbol-table) address))))) (setf lisp::*foreign-symbols* symbol-table))) (defun load-foreign (files &key (libraries '("-lc")) (base-file #-hpux (merge-pathnames *command-line-utility-name* "path:") #+hpux "library:cmucl.orig") (env ext:*environment-list*) (verbose *load-verbose*)) _N"Load-foreign loads a list of C object files into a running Lisp. The files argument should be a single file or a list of files. The files may be specified as namestrings or as pathnames. The libraries argument should be a list of library files as would be specified to ld. They will be searched in the order given. The default is just \"-lc\", i.e., the C library. The base-file argument is used to specify a file to use as the starting place for defined symbols. The default is the C start up code for Lisp. The env argument is the Unix environment variable definitions for the invocation of the linker. The default is the environment passed to Lisp." (let ((output-file (pick-temporary-file-name)) (symbol-table-file (pick-temporary-file-name)) (error-output (make-string-output-stream)) (files (if (atom files) (list files) files))) (when verbose (format t (intl:gettext ";;; Running library:load-foreign.csh...~%")) (force-output)) #+hpux (dolist (f files) (with-open-file (stream f :element-type '(unsigned-byte 16)) (unless (let ((sysid (read-byte stream))) (or (eql sysid cpu-pa-risc1-0) (and (>= sysid cpu-pa-risc1-1) (<= sysid cpu-pa-risc-max)))) (error (intl:gettext "Object file is wrong format, so can't load-foreign:~ ~% ~S") f)) (unless (eql (read-byte stream) reloc-magic) (error (intl:gettext "Object file is not relocatable, so can't load-foreign:~ ~% ~S") f)))) (let ((proc (ext:run-program "library:load-foreign.csh" (list* (or *previous-linked-object-file* (namestring (truename base-file))) (format nil "~X" *foreign-segment-free-pointer*) output-file symbol-table-file (append (mapcar #'(lambda (name) (or (unix-namestring name) (error 'simple-file-error :pathname name :format-control "File does not exist: ~A." :format-arguments (list name)))) files) libraries)) :env env :input nil :output error-output :error :output))) (unless proc (error (intl:gettext "Could not run library:load-foreign.csh"))) (unless (zerop (ext:process-exit-code proc)) (system:serve-all-events 0) (error (intl:gettext "library:load-foreign.csh failed:~%~A") (get-output-stream-string error-output))) (load-object-file output-file) (parse-symbol-table symbol-table-file) (unix:unix-unlink symbol-table-file) (let ((old-file *previous-linked-object-file*)) (setf *previous-linked-object-file* output-file) (when old-file (unix:unix-unlink old-file))))) (when verbose (format t (intl:gettext ";;; Done.~%")) (force-output))) (export '(alternate-get-global-address)) (defun alternate-get-global-address (symbol) (declare (type simple-string symbol) (ignore symbol)) 0) ) ;; #-(or linux bsd solaris irix) ;; Modern dlopen()-based loading of shared libraries #+(or linux bsd solaris irix) (progn (defconstant rtld-lazy 1 _N"Lazy function call binding") (defconstant rtld-now 2 _N"Immediate function call binding") #+(and linux glibc2) (defconstant rtld-binding-mask #x3 _N"Mask of binding time value") (defconstant rtld-global #-irix #x100 #+irix 4 _N"If set the symbols of the loaded object and its dependencies are made visible as if the object were linked directly into the program") (defvar *global-table* nil) ;;; Dynamically loaded stuff isn't there upon restoring from a ;;; save--this is primarily for irix, which resolves tzname at ;;; runtime, resulting in *global-table* being set in the saved core ;;; image, resulting in havoc upon restart. #-linkage-table (pushnew #'(lambda () (setq *global-table* nil)) ext:*after-save-initializations*) (defvar *dso-linker* #+solaris "/usr/ccs/bin/ld" #-solaris "/usr/bin/ld") (alien:def-alien-routine dlopen system-area-pointer (file c-call:c-string) (mode c-call:int)) (alien:def-alien-routine dlsym system-area-pointer (lib system-area-pointer) (name c-call:c-string)) (alien:def-alien-routine dlclose void (lib system-area-pointer)) (alien:def-alien-routine dlerror c-call:c-string) ;;; Ensure we've opened our own binary so can resolve global variables ;;; in the lisp image that come from libraries. This used to happen ;;; only in alternate-get-global-address, and only if no libraries ;;; were dlopened already, but that didn't work if something was ;;; dlopened before any problem global vars were used. So now we do ;;; this in any function that can add to the global-table, as well as ;;; in alternate-get-global-address. (defun ensure-lisp-table-opened () (unless *global-table* ;; Prevent recursive call if dlopen isn't defined (setf *global-table* (acons (int-sap 0) nil nil)) (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil)) (when (zerop (system:sap-int (caar *global-table*))) (error (intl:gettext "Can't open global symbol table: ~S") (dlerror))))) (defun convert-object-file-path (path) ;; Convert path to something that dlopen might like, which means ;; translating logical pathnames and converting search-lists to the ;; first path that exists. (cond ((lisp::logical-pathname-p (pathname path)) (translate-logical-pathname path)) ((ignore-errors (ext:search-list-defined-p (pathname path))) (ext:enumerate-search-list (s (pathname path) path) (when (probe-file s) (return s)))) (t path))) (defun load-object-file (file &optional (recordp t)) (ensure-lisp-table-opened) ; rtld global: so it can find all the symbols previously loaded ; rtld now: that way dlopen will fail if not all symbols are defined. (let* ((filename (namestring (convert-object-file-path file))) (sap (dlopen filename (logior rtld-now rtld-global)))) (cond ((zerop (sap-int sap)) (let ((err-string (dlerror)) (sap (dlopen filename (logior rtld-lazy rtld-global)))) ;; For some reason dlerror always seems to return NIL, ;; which isn't very informative. (when (zerop (sap-int sap)) (return-from load-object-file (values nil (format nil (intl:gettext "Can't open object ~S: ~S") file err-string)))) (dlclose sap) (return-from load-object-file (values nil (format nil (intl:gettext "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S") file err-string))))) ((and recordp (null (assoc sap *global-table* :test #'sap=))) (setf *global-table* (acons sap file *global-table*))) (t nil)))) ;;; Clear close all dlopened libraries and clear out the entries in ;;; *global-table*, prior to doing a save-lisp. (defun close-global-table () (loop for lib-entry in *global-table* for (sap) = lib-entry do (progn (dlclose sap) ;; Probably not necessary, but neater than leaving around ;; stale handles in the saved image. (setf (car lib-entry) (int-sap 0))))) ;;; Open all the libraries in *GLOBAL-TABLE*. We open them in the same ;;; order as the first time they were loaded, so that any dependencies ;;; on load order are respected. (defun reinitialize-global-table () (loop for lib-entry in (reverse *global-table*) for (sap . lib-path) = lib-entry when lib-path do (loop (restart-case (let ((new-sap (dlopen (namestring (convert-object-file-path lib-path)) (logior rtld-now rtld-global)))) (cond ((zerop (sap-int new-sap)) ;; We're going down (error (intl:gettext "Couldn't open library ~S: ~S") lib-path (dlerror))) (t (format t (intl:gettext "Reloaded library ~S~%") lib-path) (force-output))) (setf (car lib-entry) new-sap) (return)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore library and continue") stream)) (return)) (try-again () :report (lambda (stream) (write-string (intl:gettext "Try reloading again") stream)) ) (new-library () :report (lambda (stream) (write-string (intl:gettext "Choose new library path") stream)) (format *query-io* (intl:gettext "Enter new library path: ")) (setf lib-path (read)))))) (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage" (alien:function c-call:void)))) (defun alternate-get-global-address (symbol) (ensure-lisp-table-opened) ;; find the symbol in any of the loaded objects, ;; search in reverse order of loading, later loadings ;; take precedence (let ((result 0)) (do ((table *global-table* (cdr table))) ((or (null (car table)) (not (zerop result)))) (setq result (sap-int (dlsym (caar table) symbol)))) (values result))) (defun load-foreign (files &key (libraries '("-lc")) (base-file nil) (env ext:*environment-list*) (verbose *load-verbose*)) _N"Load C object files into the running Lisp. The FILES argument should be a single file or a list of files. The files may be specified as namestrings or as pathnames. The LIBRARIES argument should be a list of library files as would be specified to ld. They will be searched in the order given. The default is just \"-lc\", i.e., the C library. The BASE-FILE argument is used to specify a file to use as the starting place for defined symbols. The default is the C start up code for Lisp. The ENV argument is the Unix environment variable definitions for the invocation of the linker. The default is the environment passed to Lisp." ;; Note: dlopen remembers the name of an object, when dlopen()ing ;; the same name twice, the old object is reused. (declare (ignore base-file)) ;; if passed a single shared object that can be loaded directly via ;; dlopen(), do that instead of using the linker (when (atom files) (when verbose (format t (intl:gettext ";;; Opening as shared library ~A ...~%") files)) (multiple-value-bind (ok error-string) (load-object-file files) (cond (ok (when verbose (format t (intl:gettext ";;; Done.~%")) (force-output)) (return-from load-foreign)) (error-string (format t "~A~%" error-string) (force-output)))) ;; If we get here, we couldn't open the file as a shared library. ;; Try again assuming it's an object file. (when verbose (format t (intl:gettext ";;; Trying as object file ~A...~%") files))) (let ((output-file (pick-temporary-file-name (concatenate 'string "/tmp/~D~C" (string (gensym))))) (error-output (make-string-output-stream))) (when verbose (format t (intl:gettext ";;; Running ~A...~%") *dso-linker*) (force-output)) (let ((proc (ext:run-program *dso-linker* (list* #+(or solaris linux) "-G" #+(or freebsd OpenBSD NetBSD irix) "-shared" #+darwin "-dylib" #+darwin "-arch" #+darwin "i386" "-o" output-file ;; Cause all specified libs to be loaded in full #+(or freebsd OpenBSD linux NetBSD) "--whole-archive" #+solaris "-z" #+solaris "allextract" #+darwin "-all_load" (append (mapcar #'(lambda (name) (or (unix-namestring name) (error 'simple-file-error :pathname name :format-control (intl:gettext "File does not exist: ~A.") :format-arguments (list name)))) (if (atom files) (list files) files)) ;; Return to default ld behaviour for libs (list #+(or freebsd OpenBSD linux NetBSD) "--no-whole-archive" #+solaris "-z" #+solaris "defaultextract") libraries)) ;; on Linux/AMD64, we need to tell the platform linker to use ;; the 32-bit linking mode instead of the default 64-bit mode. ;; This can be done either via the LDEMULATION environment ;; variable, or via the "-m" command-line option. Here we ;; assume that LDEMULATION will be ignored by the platform ;; linker on Linux/i386 platforms. :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env) :input nil :output error-output :error :output))) (unless proc (error (intl:gettext "Could not run ~A") *dso-linker*)) (unless (zerop (ext:process-exit-code proc)) (system:serve-all-events 0) (error (intl:gettext "~A failed:~%~A") *dso-linker* (get-output-stream-string error-output))) (load-object-file output-file nil) (unix:unix-unlink output-file)) (when verbose (format t (intl:gettext ";;; Done.~%")) (force-output)))) #+linkage-table (pushnew #'reinitialize-global-table ext:*after-save-initializations*) ) ;; #+(or linux bsd solaris irix) cmucl-21a/src/code/format-time.lisp000066400000000000000000000231111260377556400173750ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/format-time.lisp $") ;;; ;;; ********************************************************************** ;;; Really slick time printing routines built upon the Common Lisp ;;; format function. ;;; Written by Jim Healy, September 1987. ;;; ********************************************************************** (in-package :extensions) (intl:textdomain "cmucl") (export '(format-universal-time format-decoded-time)) (defconstant abbrev-weekday-table '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) (defconstant long-weekday-table '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (defconstant abbrev-month-table '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) (defconstant long-month-table '#("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) ;;; The timezone-table is incomplete but workable. (defconstant timezone-table '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST")) (defconstant daylight-table '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT")) ;;; Valid-Destination-P ensures the destination stream is okay ;;; for the Format function. (defun valid-destination-p (destination) (or (not destination) (eq destination 't) (streamp destination) (and (stringp destination) (array-has-fill-pointer-p destination)))) ;;; Format-Universal-Time - External. (defun format-universal-time (destination universal-time &key (timezone nil) (style :short) (date-first t) (print-seconds t) (print-meridian t) (print-timezone t) (print-weekday t)) "Format-Universal-Time formats a string containing the time and date given by universal-time in a common manner. The destination is any destination which can be accepted by the Format function. The timezone keyword is an integer specifying hours west of Greenwich. The style keyword can be :short (numeric date), :long (months and weekdays expressed as words), :abbreviated (like :long but words are abbreviated), :rfc1123 (conforming to RFC 1123), :government (of the form \"XX Mon XX XX:XX:XX\"), or :iso8601 (conforming to ISO 8601), which is the recommended way of printing date and time. The keyword date-first, if nil, will print the time first instead of the date (the default). The print- keywords, if nil, inhibit the printing of the obvious part of the time/date." (unless (valid-destination-p destination) (error (intl:gettext "~A: Not a valid format destination.") destination)) (unless (integerp universal-time) (error (intl:gettext "~A: Universal-Time should be an integer.") universal-time)) (when timezone (unless (and (rationalp timezone) (<= -24 timezone 24)) (error (intl:gettext "~A: Timezone should be a rational between -24 and 24.") timezone)) (unless (zerop (rem timezone 1/3600)) (error (intl:gettext "~A: Timezone is not a second (1/3600) multiple.") timezone))) (multiple-value-bind (secs mins hours day month year dow dst tz) (if timezone (decode-universal-time universal-time timezone) (decode-universal-time universal-time)) (declare (fixnum secs mins hours day month year dow)) (let ((time-string "~2,'0D:~2,'0D") (date-string (case style (:short "~D/~D/~2,'0D") ;; MM/DD/YY ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, YYYY (:rfc1123 "~2,'0D ~A ~4,'0D") ;; DD Mon YYYY (:government "~2,'0D ~:@(~A~) ~2,'0D") ;; DD MON YY (:iso8601 "~4,'0D-~2,'0D-~2,'0D") ;; YYYY-MM-DD (t (error (intl:gettext "~A: Unrecognized :style keyword value.") style)))) (time-args (case style ((:rfc1123 :iso8601) (list mins hours)) (t (list mins (max (mod hours 12) (1+ (mod (1- hours) 12))))))) (date-args (case style (:short (list month day (mod year 100))) (:abbreviated (list (svref abbrev-month-table (1- month)) day year)) (:long (list (svref long-month-table (1- month)) day year)) (:rfc1123 (list day (svref abbrev-month-table (1- month)) year)) (:government (list day (svref abbrev-month-table (1- month)) (mod year 100))) (:iso8601 (list year month day)))) (timezone-name (case style (:rfc1123 (timezone-rfc1123-name dst tz)) (:iso8601 (timezone-iso8601-name dst tz)) (t (timezone-name dst tz))))) (declare (simple-string time-string date-string timezone-name)) (when print-weekday (push (case style ((:short :long) (svref long-weekday-table dow)) ((:abbreviated :rfc1123 :government :iso8601) (svref abbrev-weekday-table dow))) date-args) (setq date-string (concatenate 'simple-string "~A, " date-string))) (when (or print-seconds (eq style :government)) (push secs time-args) (setq time-string (concatenate 'simple-string time-string ":~2,'0D"))) (when (and print-meridian (not (member style '(:rfc1123 :iso8601)))) (push (signum (floor hours 12)) time-args) (setq time-string (concatenate 'simple-string time-string " ~[am~;pm~]"))) (apply #'format destination (if (or date-first (eq style :iso8601)) (concatenate 'simple-string date-string " " time-string (when print-timezone (if (eq style :iso8601) "~A" " ~A"))) (concatenate 'simple-string time-string " " date-string (if print-timezone " ~A"))) (if (or date-first (eq style :iso8601)) (nconc date-args (nreverse time-args) (if print-timezone (list timezone-name))) (nconc (nreverse time-args) date-args (if print-timezone (list timezone-name)))))))) (defun timezone-name (dst tz) (if (and (integerp tz) (or (and (not dst) (= tz 0)) (<= 5 tz 8))) (svref (if dst daylight-table timezone-table) tz) (multiple-value-bind (rest seconds) (truncate (* (if dst (1- tz) tz) 60 60) 60) (multiple-value-bind (hours minutes) (truncate rest 60) (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]" (if (minusp tz) #\- #\+) (abs hours) (not (and (zerop minutes) (zerop seconds))) (abs minutes) (not (zerop seconds)) (abs seconds)))))) ;;; RFC 1123 style timezone: GMT, +1000, -1000. ;;; Timezone is the negative of the CL timezone. ;;; (defun timezone-rfc1123-name (dst tz) (let ((tz (- tz))) (if (and (integerp tz) (or (and (not dst) (= tz 0)) (<= 5 tz 8))) (svref (if dst daylight-table timezone-table) tz) (multiple-value-bind (hours minutes) (truncate (if dst (1+ tz) tz)) (format nil "~C~2,'0D~2,'0D" (if (minusp tz) #\- #\+) (abs hours) (abs (truncate (* minutes 60)))))))) ;;; ISO 8601 style timezone: Z, +1000, -1000. ;;; Timezone is the negative of the CL timezone. ;;; (defun timezone-iso8601-name (dst tz) (let ((tz (- tz))) (if (and (not dst) (= tz 0)) "Z" (multiple-value-bind (hours minutes) (truncate (if dst (1+ tz) tz)) (format nil "~C~2,'0D:~2,'0D" (if (minusp tz) #\- #\+) (abs hours) (abs (truncate (* minutes 60)))))))) ;;; Format-Decoded-Time - External. (defun format-decoded-time (destination seconds minutes hours day month year &key (timezone nil) (style :short) (date-first t) (print-seconds t) (print-meridian t) (print-timezone t) (print-weekday t)) "Format-Decoded-Time formats a string containing decoded-time expressed in a humanly-readable manner. The destination is any destination which can be accepted by the Format function. The timezone keyword is an integer specifying hours west of Greenwich. The style keyword can be :short (numeric date), :long (months and weekdays expressed as words), or :abbreviated (like :long but words are abbreviated). The keyword date-first, if nil, will cause the time to be printed first instead of the date (the default). The print- keywords, if nil, inhibit the printing of certain semi-obvious parts of the string." (unless (valid-destination-p destination) (error (intl:gettext "~A: Not a valid format destination.") destination)) (unless (and (integerp seconds) (<= 0 seconds 59)) (error (intl:gettext "~A: Seconds should be an integer between 0 and 59.") seconds)) (unless (and (integerp minutes) (<= 0 minutes 59)) (error (intl:gettext "~A: Minutes should be an integer between 0 and 59.") minutes)) (unless (and (integerp hours) (<= 0 hours 23)) (error (intl:gettext "~A: Hours should be an integer between 0 and 23.") hours)) (unless (and (integerp day) (<= 1 day 31)) (error (intl:gettext "~A: Day should be an integer between 1 and 31.") day)) (unless (and (integerp month) (<= 1 month 12)) (error (intl:gettext "~A: Month should be an integer between 1 and 12.") month)) (unless (and (integerp year) (plusp year)) (error (intl:gettext "~A: Hours should be an non-negative integer.") year)) (when timezone (unless (and (integerp timezone) (<= 0 timezone 32)) (error (intl:gettext "~A: Timezone should be an integer between 0 and 32.") timezone))) (format-universal-time destination (encode-universal-time seconds minutes hours day month year) :timezone timezone :style style :date-first date-first :print-seconds print-seconds :print-meridian print-meridian :print-timezone print-timezone :print-weekday print-weekday)) cmucl-21a/src/code/format.lisp000066400000000000000000003635521260377556400164610ustar00rootroot00000000000000;;; -*- Package: FORMAT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/format.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. ;;; ;;; Written by William Lott, with lots of stuff stolen from the previous ;;; version by David Adam and later rewritten by Bill Maddox. ;;; (in-package "FORMAT") (use-package "EXT") (use-package "KERNEL") (intl:textdomain "cmucl") (in-package "LISP") (export '(format formatter)) (in-package "FORMAT") (defstruct (format-directive (:print-function %print-format-directive)) (string (required-argument) :type simple-string) (start (required-argument) :type (and unsigned-byte fixnum)) (end (required-argument) :type (and unsigned-byte fixnum)) (character (required-argument) :type base-char) (colonp nil :type (member t nil)) (atsignp nil :type (member t nil)) (params nil :type list)) (defun %print-format-directive (struct stream depth) (declare (ignore depth)) (print-unreadable-object (struct stream) (write-string (format-directive-string struct) stream :start (format-directive-start struct) :end (format-directive-end struct)))) (defvar *format-directive-expanders* (make-array char-code-limit :initial-element nil)) (defvar *format-directive-interpreters* (make-array char-code-limit :initial-element nil)) (defun %print-format-error (condition stream) (cl:format stream (intl:gettext "~:[~;Error in format: ~]~ ~?~@[~% ~A~% ~V@T^~]") (format-error-print-banner condition) (format-error-complaint condition) (format-error-arguments condition) (format-error-control-string condition) (format-error-offset condition))) (defvar *default-format-error-control-string* nil) (defvar *default-format-error-offset* nil) (define-condition format-error (error) ((complaint :reader format-error-complaint :initarg :complaint) (arguments :reader format-error-arguments :initarg :arguments :initform nil) (control-string :reader format-error-control-string :initarg :control-string :initform *default-format-error-control-string*) (offset :reader format-error-offset :initarg :offset :initform *default-format-error-offset*) (print-banner :reader format-error-print-banner :initarg :print-banner :initform t)) (:report %print-format-error)) ;;;; TOKENIZE-CONTROL-STRING (defun tokenize-control-string (string) (declare (simple-string string)) (let ((index 0) (end (length string)) (result nil) (in-block nil) (pprint nil) (semi nil) (justification-semi 0)) (loop (let ((next-directive (or (position #\~ string :start index) end))) (when (> next-directive index) (push (subseq string index next-directive) result)) (when (= next-directive end) (return)) (let* ((directive (parse-directive string next-directive)) (directive-char (format-directive-character directive))) ;; We are looking for illegal combinations of format ;; directives in the control string. See the last paragraph ;; of CLHS 22.3.5.2: "an error is also signaled if the ;; ~<...~:;...~> form of ~<...~> is used in the same format ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T." (cond ((char= #\< directive-char) ;; Found a justification or logical block (setf in-block t)) ((and in-block (char= #\; directive-char)) ;; Found a semi colon in a justification or logical block (setf semi t)) ((char= #\> directive-char) ;; End of justification or logical block. Figure out which. (setf in-block nil) (cond ((format-directive-colonp directive) ;; A logical-block directive. Note that fact, and also ;; note that we don't care if we found any ~; ;; directives in the block. (setf pprint t) (setf semi nil)) (semi ;; A justification block with a ~; directive in it. (incf justification-semi)))) ((and (not in-block) (or (and (char= #\T directive-char) (format-directive-colonp directive)) (char= #\W directive-char) (char= #\_ directive-char) (char= #\I directive-char))) (setf pprint t))) (push directive result) (setf index (format-directive-end directive))))) (when (and pprint (plusp justification-semi)) (error 'format-error :complaint (intl:gettext "A justification directive cannot be in the same format string~%~ as ~~W, ~~I, ~~:T, or a logical-block directive.") :control-string string :offset 0)) (nreverse result))) (defun parse-directive (string start) (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) (end (length string))) (flet ((get-char () (if (= posn end) (error 'format-error :complaint (intl:gettext "String ended before directive was found.") :control-string string :offset start) (schar string posn)))) (loop (let ((char (get-char))) (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) (multiple-value-bind (param new-posn) (parse-integer string :start posn :junk-allowed t) (push (cons posn param) params) (setf posn new-posn) (case (get-char) (#\,) ((#\: #\@) (decf posn)) (t (return))))) ((or (char= char #\v) (char= char #\V)) (push (cons posn :arg) params) (incf posn) (case (get-char) (#\,) ((#\: #\@) (decf posn)) (t (return)))) ((char= char #\#) (push (cons posn :remaining) params) (incf posn) (case (get-char) (#\,) ((#\: #\@) (decf posn)) (t (return)))) ((char= char #\') (incf posn) (push (cons posn (get-char)) params) (incf posn) (unless (char= (get-char) #\,) (decf posn))) ((char= char #\,) (push (cons posn nil) params)) ((char= char #\:) (if colonp (error 'format-error :complaint (intl:gettext "Too many colons supplied.") :control-string string :offset posn) (setf colonp t))) ((char= char #\@) (if atsignp (error 'format-error :complaint (intl:gettext "Too many at-signs supplied.") :control-string string :offset posn) (setf atsignp t))) (t (return)))) (incf posn)) (let ((char (get-char))) (when (char= char #\/) (let ((closing-slash (position #\/ string :start (1+ posn)))) (if closing-slash (setf posn closing-slash) (error 'format-error :complaint (intl:gettext "No matching closing slash.") :control-string string :offset posn)))) (make-format-directive :string string :start start :end (1+ posn) :character (char-upcase char) :colonp colonp :atsignp atsignp :params (nreverse params)))))) ;;;; Specials used to communicate information. ;;; *UP-UP-AND-OUT-ALLOWED* -- internal. ;;; ;;; Used both by the expansion stuff and the interpreter stuff. When it is ;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. ;;; (defvar *up-up-and-out-allowed* nil) ;;; *LOGICAL-BLOCK-POPPER* -- internal. ;;; ;;; Used by the interpreter stuff. When it non-NIL, its a function that will ;;; invoke PPRINT-POP in the right lexical environemnt. ;;; (defvar *logical-block-popper* nil) ;;; *EXPANDER-NEXT-ARG-MACRO* -- internal. ;;; ;;; Used by the expander stuff. This is bindable so that ~<...~:> ;;; can change it. ;;; (defvar *expander-next-arg-macro* 'expander-next-arg) ;;; *ONLY-SIMPLE-ARGS* -- internal. ;;; ;;; Used by the expander stuff. Initially starts as T, and gets set to NIL ;;; if someone needs to do something strange with the arg list (like use ;;; the rest, or something). ;;; (defvar *only-simple-args*) ;;; *ORIG-ARGS-AVAILABLE* -- internal. ;;; ;;; Used by the expander stuff. We do an initial pass with this as NIL. ;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try ;;; again with it bound to T. If this is T, we don't try to do anything ;;; fancy with args. ;;; (defvar *orig-args-available* nil) ;;; *SIMPLE-ARGS* -- internal. ;;; ;;; Used by the expander stuff. List of (symbol . offset) for simple args. ;;; (defvar *simple-args*) ;;;; FORMAT (defun format (destination control-string &rest format-arguments) "Provides various facilities for formatting output. CONTROL-STRING contains a string to be output, possibly with embedded directives, which are flagged with the escape character \"~\". Directives generally expand into additional text to be output, usually consuming one or more of the FORMAT-ARGUMENTS in the process. A few useful directives are: ~A or ~nA Prints one argument as if by PRINC ~S or ~nS Prints one argument as if by PRIN1 ~D or ~nD Prints one argument as a decimal integer ~% Does a TERPRI ~& Does a FRESH-LINE where n is the width of the field in which the object is printed. DESTINATION controls where the result will go. If DESTINATION is T, then the output is sent to the standard output stream. If it is NIL, then the output is returned in a string as the value of the call. Otherwise, DESTINATION must be a stream to which the output will be sent. Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" FORMAT has many additional capabilities not described here. Consult Section 22.3 (Formatted Output) of the ANSI Common Lisp standard for details." (etypecase destination (null (with-output-to-string (stream) (%format stream control-string format-arguments))) (string (with-output-to-string (stream destination) (%format stream control-string format-arguments))) ((member t) (%format *standard-output* control-string format-arguments) nil) (stream (%format destination control-string format-arguments) nil))) (defun %format (stream string-or-fun orig-args &optional (args orig-args)) (if (functionp string-or-fun) (apply string-or-fun stream args) (catch 'up-and-out (let* ((string (etypecase string-or-fun (simple-string string-or-fun) (string (coerce string-or-fun 'simple-string)))) (*default-format-error-control-string* string) (*logical-block-popper* nil)) (interpret-directive-list stream (tokenize-control-string string) orig-args args))))) (defun interpret-directive-list (stream directives orig-args args) (if directives (let ((directive (car directives))) (etypecase directive (simple-string (write-string directive stream) (interpret-directive-list stream (cdr directives) orig-args args)) (format-directive (multiple-value-bind (new-directives new-args) (let ((function (svref *format-directive-interpreters* (char-code (format-directive-character directive)))) (*default-format-error-offset* (1- (format-directive-end directive)))) (unless function (error 'format-error :complaint (intl:gettext "Unknown format directive."))) (multiple-value-bind (new-directives new-args) (funcall function stream directive (cdr directives) orig-args args) (values new-directives new-args))) (interpret-directive-list stream new-directives orig-args new-args))))) args)) ;;;; FORMATTER (defmacro formatter (control-string) `#',(%formatter control-string)) (defun %formatter (control-string) (block nil (catch 'need-orig-args (let* ((*simple-args* nil) (*only-simple-args* t) (guts (expand-control-string control-string)) (args nil)) (dolist (arg *simple-args*) (push `(,(car arg) (error 'format-error :complaint (intl:gettext "Required argument missing") :control-string ,control-string :offset ,(cdr arg))) args)) (return `(lambda (stream &optional ,@args &rest args) ,guts args)))) (let ((*orig-args-available* t) (*only-simple-args* nil)) `(lambda (stream &rest orig-args) (let ((args orig-args)) ,(expand-control-string control-string) args))))) (defun expand-control-string (string) (let* ((string (etypecase string (simple-string string) (string (coerce string 'simple-string)))) (*default-format-error-control-string* string) (directives (tokenize-control-string string))) `(block nil ,@(expand-directive-list directives)))) (defun expand-directive-list (directives) (let ((results nil) (remaining-directives directives)) (loop (unless remaining-directives (return)) (multiple-value-bind (form new-directives) (expand-directive (car remaining-directives) (cdr remaining-directives)) (push form results) (setf remaining-directives new-directives))) (reverse results))) (defun expand-directive (directive more-directives) (etypecase directive (format-directive (let ((expander (aref *format-directive-expanders* (char-code (format-directive-character directive)))) (*default-format-error-offset* (1- (format-directive-end directive)))) (if expander (funcall expander directive more-directives) (error 'format-error :complaint (intl:gettext "Unknown directive."))))) (simple-string (values `(write-string ,directive stream) more-directives)))) (defun expand-next-arg (&optional offset) (if (or *orig-args-available* (not *only-simple-args*)) `(,*expander-next-arg-macro* ,*default-format-error-control-string* ,(or offset *default-format-error-offset*)) (let ((symbol (gensym "FORMAT-ARG-"))) (push (cons symbol (or offset *default-format-error-offset*)) *simple-args*) symbol))) (defun need-hairy-args () (when *only-simple-args* )) ;;;; Format directive definition macros and runtime support. (defmacro expander-next-arg (string offset) `(if args (pop args) (error 'format-error :complaint (intl:gettext "No more arguments.") :control-string ,string :offset ,offset))) (defmacro expander-pprint-next-arg (string offset) `(progn (when (null args) (error 'format-error :complaint (intl:gettext "No more arguments.") :control-string ,string :offset ,offset)) (pprint-pop) (pop args))) (eval-when (:compile-toplevel :execute) ;;; NEXT-ARG -- internal. ;;; ;;; This macro is used to extract the next argument from the current arg list. ;;; This is the version used by format directive interpreters. ;;; (defmacro next-arg (&optional offset) `(progn (when (null args) (error 'format-error :complaint (intl:gettext "No more arguments.") ,@(when offset `(:offset ,offset)))) (when *logical-block-popper* (funcall *logical-block-popper*)) (pop args))) (defmacro def-complex-format-directive (char lambda-list &body body) (let ((defun-name (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" char))) (directive (gensym)) (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(progn (defun ,defun-name (,directive ,directives) ,@(if lambda-list `((let ,(mapcar #'(lambda (var) `(,var (,(intern (concatenate 'string "FORMAT-DIRECTIVE-" (symbol-name var)) (symbol-package 'foo)) ,directive))) (butlast lambda-list)) ,@body)) `((declare (ignore ,directive ,directives)) ,@body))) (%set-format-directive-expander ,char #',defun-name)))) (defmacro def-format-directive (char lambda-list &body body) (let ((directives (gensym)) (declarations nil) (body-without-decls body)) (loop (let ((form (car body-without-decls))) (unless (and (consp form) (eq (car form) 'declare)) (return)) (push (pop body-without-decls) declarations))) (setf declarations (reverse declarations)) `(def-complex-format-directive ,char (,@lambda-list ,directives) ,@declarations (values (progn ,@body-without-decls) ,directives)))) (defmacro expand-bind-defaults (specs params &body body) (once-only ((params params)) (if specs (collect ((expander-bindings) (runtime-bindings)) (dolist (spec specs) (destructuring-bind (var default) spec (let ((symbol (gensym))) (expander-bindings `(,var ',symbol)) (runtime-bindings `(list ',symbol (let* ((param-and-offset (pop ,params)) (offset (car param-and-offset)) (param (cdr param-and-offset))) (case param (:arg `(or ,(expand-next-arg offset) ,,default)) (:remaining (setf *only-simple-args* nil) '(length args)) ((nil) ,default) (t param)))))))) `(let ,(expander-bindings) `(let ,(list ,@(runtime-bindings)) ,@(if ,params (error 'format-error :complaint (intl:gettext "Too many parameters, expected no more than ~D") :arguments (list ,(length specs)) :offset (caar ,params))) ,,@body))) `(progn (when ,params (error 'format-error :complaint (intl:gettext "Too many parameters, expected no more than 0") :offset (caar ,params))) ,@body)))) (defmacro def-complex-format-interpreter (char lambda-list &body body) (let ((defun-name (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER" char))) (directive (gensym)) (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(progn (defun ,defun-name (stream ,directive ,directives orig-args args) (declare (ignorable stream orig-args args)) ,@(if lambda-list `((let ,(mapcar #'(lambda (var) `(,var (,(intern (concatenate 'string "FORMAT-DIRECTIVE-" (symbol-name var)) (symbol-package 'foo)) ,directive))) (butlast lambda-list)) (values (progn ,@body) args))) `((declare (ignore ,directive ,directives)) ,@body))) (%set-format-directive-interpreter ,char #',defun-name)))) (defmacro def-format-interpreter (char lambda-list &body body) (let ((directives (gensym))) `(def-complex-format-interpreter ,char (,@lambda-list ,directives) ,@body ,directives))) (defmacro interpret-bind-defaults (specs params &body body) (once-only ((params params)) (collect ((bindings)) (dolist (spec specs) (destructuring-bind (var default) spec (bindings `(,var (let* ((param-and-offset (pop ,params)) (offset (car param-and-offset)) (param (cdr param-and-offset))) (case param (:arg ;; If the value of ~V is NIL, it's the ;; same as if it weren't given at all. ;; See CLHS 22.3. (or (next-arg offset) ,default)) (:remaining (length args)) ((nil) ,default) (t param))))))) `(let* ,(bindings) (when ,params (error 'format-error :complaint (intl:gettext "Too many parameters, expected no more than ~D") :arguments (list ,(length specs)) :offset (caar ,params))) ,@body)))) ); eval-when (defun %set-format-directive-expander (char fn) (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) char) (defun %set-format-directive-interpreter (char fn) (setf (aref *format-directive-interpreters* (char-code (char-upcase char))) fn) char) (defun find-directive (directives kind stop-at-semi) (if directives (let ((next (car directives))) (if (format-directive-p next) (let ((char (format-directive-character next))) (if (or (char= kind char) (and stop-at-semi (char= char #\;))) (car directives) (find-directive (cdr (flet ((after (char) (member (find-directive (cdr directives) char nil) directives))) (case char (#\( (after #\))) (#\< (after #\>)) (#\[ (after #\])) (#\{ (after #\})) (t directives)))) kind stop-at-semi))) (find-directive (cdr directives) kind stop-at-semi))))) ;;;; Simple outputting noise. (defun format-write-field (stream string mincol colinc minpad padchar padleft) (unless padleft (write-string string stream)) (dotimes (i minpad) (write-char padchar stream)) (and mincol minpad colinc (do ((chars (+ (length string) (max 0 minpad)) (+ chars colinc))) ((>= chars mincol)) (dotimes (i colinc) (write-char padchar stream)))) (when padleft (write-string string stream))) (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) (format-write-field stream (if (or arg (not colonp)) (princ-to-string arg) "()") mincol colinc minpad padchar atsignp)) (def-format-directive #\A (colonp atsignp params) (if params (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp ,mincol ,colinc ,minpad ,padchar)) `(princ ,(if colonp `(or ,(expand-next-arg) "()") (expand-next-arg)) stream))) (def-format-interpreter #\A (colonp atsignp params) (if params (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params (format-princ stream (next-arg) colonp atsignp mincol colinc minpad padchar)) (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) (format-write-field stream (if (or arg (not colonp)) (prin1-to-string arg) "()") mincol colinc minpad padchar atsignp)) (def-format-directive #\S (colonp atsignp params) (cond (params (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp ,mincol ,colinc ,minpad ,padchar))) (colonp `(let ((arg ,(expand-next-arg))) (if arg (prin1 arg stream) (princ "()" stream)))) (t `(prin1 ,(expand-next-arg) stream)))) (def-format-interpreter #\S (colonp atsignp params) (cond (params (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params (format-prin1 stream (next-arg) colonp atsignp mincol colinc minpad padchar))) (colonp (let ((arg (next-arg))) (if arg (prin1 arg stream) (princ "()" stream)))) (t (prin1 (next-arg) stream)))) (def-format-directive #\C (colonp atsignp params) (expand-bind-defaults () params (if colonp `(format-print-named-character ,(expand-next-arg) stream) (if atsignp `(prin1 ,(expand-next-arg) stream) `(write-char ,(expand-next-arg) stream))))) (def-format-interpreter #\C (colonp atsignp params) (interpret-bind-defaults () params (if colonp (format-print-named-character (next-arg) stream) (if atsignp (prin1 (next-arg) stream) (write-char (next-arg) stream))))) #-unicode (defun format-print-named-character (char stream) (let* ((name (char-name char))) (cond (name (write-string name stream)) ((<= 0 (char-code char) 31) ;; Print control characters as "^" (write-char #\^ stream) (write-char (code-char (+ 64 (char-code char))) stream)) (t (write-char char stream))))) #+unicode (defun format-print-named-character (char stream) (cond ((and (graphic-char-p char) (char/= char #\space)) ;; Graphic characters (except space) print the same as ~C. (write-char char stream)) (t (let* ((name (char-name char))) (write-string name stream))))) (def-format-directive #\W (colonp atsignp params) (expand-bind-defaults () params (if (or colonp atsignp) `(let (,@(when colonp '((*print-pretty* t))) ,@(when atsignp '((*print-level* nil) (*print-length* nil)))) (output-object ,(expand-next-arg) stream)) `(output-object ,(expand-next-arg) stream)))) (def-format-interpreter #\W (colonp atsignp params) (interpret-bind-defaults () params (let ((*print-pretty* (or colonp *print-pretty*)) (*print-level* (and atsignp *print-level*)) (*print-length* (and atsignp *print-length*))) (output-object (next-arg) stream)))) ;;;; Integer outputting. ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing ;;; directives. The parameters are interpreted as defined for ~D. ;;; (defun format-print-integer (stream number print-commas-p print-sign-p radix mincol padchar commachar commainterval) (let ((*print-base* radix) (*print-radix* nil)) (if (integerp number) (let* ((text (princ-to-string (abs number))) (commaed (if print-commas-p (format-add-commas text commachar commainterval) text)) (signed (cond ((minusp number) (concatenate 'string "-" commaed)) (print-sign-p (concatenate 'string "+" commaed)) (t commaed)))) ;; colinc = 1, minpad = 0, padleft = t (format-write-field stream signed mincol 1 0 padchar t)) (princ number stream)))) (defun format-add-commas (string commachar commainterval) (let ((length (length string))) (multiple-value-bind (commas extra) (truncate (1- length) commainterval) (let ((new-string (make-string (+ length commas))) (first-comma (1+ extra))) (replace new-string string :end1 first-comma :end2 first-comma) (do ((src first-comma (+ src commainterval)) (dst first-comma (+ dst commainterval 1))) ((= src length)) (setf (schar new-string dst) commachar) (replace new-string string :start1 (1+ dst) :start2 src :end2 (+ src commainterval))) new-string)))) (defun expand-format-integer (base colonp atsignp params) (if (or colonp atsignp params) (expand-bind-defaults ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp ,base ,mincol ,padchar ,commachar ,commainterval)) `(write ,(expand-next-arg) :stream stream :base ,base :radix nil :escape nil))) (defmacro interpret-format-integer (base) `(if (or colonp atsignp params) (interpret-bind-defaults ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params (format-print-integer stream (next-arg) colonp atsignp ,base mincol padchar commachar commainterval)) (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) (def-format-directive #\D (colonp atsignp params) (expand-format-integer 10 colonp atsignp params)) (def-format-interpreter #\D (colonp atsignp params) (interpret-format-integer 10)) (def-format-directive #\B (colonp atsignp params) (expand-format-integer 2 colonp atsignp params)) (def-format-interpreter #\B (colonp atsignp params) (interpret-format-integer 2)) (def-format-directive #\O (colonp atsignp params) (expand-format-integer 8 colonp atsignp params)) (def-format-interpreter #\O (colonp atsignp params) (interpret-format-integer 8)) (def-format-directive #\X (colonp atsignp params) (expand-format-integer 16 colonp atsignp params)) (def-format-interpreter #\X (colonp atsignp params) (interpret-format-integer 16)) (def-format-directive #\R (colonp atsignp params) (if params (expand-bind-defaults ((base nil) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params (let ((r-arg (gensym "R-ARG-"))) `(let ((,r-arg ,(expand-next-arg))) (if ,base (format-print-integer stream ,r-arg ,colonp ,atsignp ,base ,mincol ,padchar ,commachar ,commainterval) (format-print-cardinal stream ,r-arg))))) (if atsignp (if colonp `(format-print-old-roman stream ,(expand-next-arg)) `(format-print-roman stream ,(expand-next-arg))) (if colonp `(format-print-ordinal stream ,(expand-next-arg)) `(format-print-cardinal stream ,(expand-next-arg)))))) (def-format-interpreter #\R (colonp atsignp params) (if params (interpret-bind-defaults ((base nil) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params (if base (format-print-integer stream (next-arg) colonp atsignp base mincol padchar commachar commainterval) (format-print-cardinal stream (next-arg)))) (if atsignp (if colonp (format-print-old-roman stream (next-arg)) (format-print-roman stream (next-arg))) (if colonp (format-print-ordinal stream (next-arg)) (format-print-cardinal stream (next-arg)))))) (defconstant cardinal-ones #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) (defconstant cardinal-tens #(nil nil "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")) (defconstant cardinal-teens #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) ;; See http://en.wikipedia.org/wiki/Names_of_large_numbers and also ;; http://home.hetnet.nl/~vanadovv/BignumbyN.html. This list comes ;; from the latter link. ;; ;; Leading spaces are required to get everything printed out ;; correctly. (defconstant cardinal-periods #("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" " sextillion" " septillion" " octillion" " nonillion" " decillion" " undecillion" " duodecillion" " tredecillion" " quattuordecillion" " quinquadecillion" " sedecillion" " septendecillion" " octodecillion" " novendecillion" " vigintillion" " unvigintillion" " duovigintillion" " tresvigintillion" " quattuorvigintillion" " quinquavigintillion" " sesvigintillion" " septemvigintillion" " octovigintillion" " novemvigintillion" " trigintillion" " untrigintillion" " duotrigintillion" " trestrigintillion" " quattuortrigintillion" " quinquatrigintillion" " sestrigintillion" " septentrigintillion" " octotrigintillion" " noventrigintillion" " quadragintillion" " unquadragintillion" " duoquadragintillion" " tresquadragintillion" " quattuorquadragintillion" " quinquaquadragintillion" " sesquadragintillion" " septenquadragintillion" " octoquadragintillion" " novenquadragintillion" " quinquagintillion" " unquinquagintillion" " duoquinquagintillion" " tresquinquagintillion" " quattuorquinquagintillion" " quinquaquinquagintillion" " sesquinquagintillion" " septenquinquagintillion" " octoquinquagintillion" " novenquinquagintillion" " sexagintillion" " unsexagintillion" " duosexagintillion" " tresexagintillion" " quattuorsexagintillion" " quinquasexagintillion" " sesexagintillion" " septensexagintillion" " octosexagintillion" " novensexagintillion" " septuagintillion" " unseptuagintillion" " duoseptuagintillion" " treseptuagintillion" " quattuorseptuagintillion" " quinquaseptuagintillion" " seseptuagintillion" " septenseptuagintillion" " octoseptuagintillion" " novenseptuagintillion" " octogintillion" " unoctogintillion" " duooctogintillion" " tresoctogintillion" " quattuoroctogintillion" " quinquaoctogintillion" " sexoctogintillion" " septemoctogintillion" " octooctogintillion" " novemoctogintillion" " nonagintillion" " unnonagintillion" " duononagintillion" " trenonagintillion" " quattuornonagintillion" " quinquanonagintillion" " senonagintillion" " septenonagintillion" " octononagintillion" " novenonagintillion" " centillion" " uncentillion" " duocentillion" " trescentillion" " quattuorcentillion" " quinquacentillion" " sexcentillion" " septencentillion" " octocentillion" " novencentillion" " decicentillion" " undecicentillion" " duodecicentillion" " tredecicentillion" " quattuordecicentillion" " quinquadecicentillion" " sedecicentillion" " septendecicentillion" " octodecicentillion" " novendecicentillion" " viginticentillion" " unviginticentillion" " duoviginticentillion" " tresviginticentillion" " quattuorviginticentillion" " quinquaviginticentillion" " sesviginticentillion" " septemviginticentillion" " octoviginticentillion" " novemviginticentillion" " trigintacentillion" " untrigintacentillion" " duotrigintacentillion" " trestrigintacentillion" " quattuortrigintacentillion" " quinquatrigintacentillion" " sestrigintacentillion" " septentrigintacentillion" " octotrigintacentillion" " noventrigintacentillion" " quadragintacentillion" " unquadragintacentillion" " duoquadragintacentillion" " tresquadragintacentillion" " quattuorquadragintacentillion" " quinquaquadragintacentillion" " sesquadragintacentillion" " septenquadragintacentillion" " octoquadragintacentillion" " novenquadragintacentillion" " quinquagintacentillion" " unquinquagintacentillion" " duoquinquagintacentillion" " tresquinquagintacentillion" " quattuorquinquagintacentillion" " quinquaquinquagintacentillion" " sesquinquagintacentillion" " septenquinquagintacentillion" " octoquinquagintacentillion" " novenquinquagintacentillion" " sexagintacentillion" " unsexagintacentillion" " duosexagintacentillion" " tresexagintacentillion" " quattuorsexagintacentillion" " quinquasexagintacentillion" " sesexagintacentillion" " septensexagintacentillion" " octosexagintacentillion" " novensexagintacentillion" " septuagintacentillion" " unseptuagintacentillion" " duoseptuagintacentillion" " treseptuagintacentillion" " quattuorseptuagintacentillion" " quinquaseptuagintacentillion" " seseptuagintacentillion" " septenseptuagintacentillion" " octoseptuagintacentillion" " novenseptuagintacentillion" " octogintacentillion" " unoctogintacentillion" " duooctogintacentillion" " tresoctogintacentillion" " quattuoroctogintacentillion" " quinquaoctogintacentillion" " sexoctogintacentillion" " septemoctogintacentillion" " octooctogintacentillion" " novemoctogintacentillion" " nonagintacentillion" " unnonagintacentillion" " duononagintacentillion" " trenonagintacentillion" " quattuornonagintacentillion" " quinquanonagintacentillion" " senonagintacentillion" " septenonagintacentillion" " octononagintacentillion" " novenonagintacentillion" " ducentillion" " unducentillion" " duoducentillion" " treducentillion" " quattuorducentillion" " quinquaducentillion" " seducentillion" " septenducentillion" " octoducentillion" " novenducentillion" " deciducentillion" " undeciducentillion" " duodeciducentillion" " tredeciducentillion" " quattuordeciducentillion" " quinquadeciducentillion" " sedeciducentillion" " septendeciducentillion" " octodeciducentillion" " novendeciducentillion" " vigintiducentillion" " unvigintiducentillion" " duovigintiducentillion" " tresvigintiducentillion" " quattuorvigintiducentillion" " quinquavigintiducentillion" " sesvigintiducentillion" " septemvigintiducentillion" " octovigintiducentillion" " novemvigintiducentillion" " trigintaducentillion" " untrigintaducentillion" " duotrigintaducentillion" " trestrigintaducentillion" " quattuortrigintaducentillion" " quinquatrigintaducentillion" " sestrigintaducentillion" " septentrigintaducentillion" " octotrigintaducentillion" " noventrigintaducentillion" " quadragintaducentillion" " unquadragintaducentillion" " duoquadragintaducentillion" " tresquadragintaducentillion" " quattuorquadragintaducentillion" " quinquaquadragintaducentillion" " sesquadragintaducentillion" " septenquadragintaducentillion" " octoquadragintaducentillion" " novenquadragintaducentillion" " quinquagintaducentillion" " unquinquagintaducentillion" " duoquinquagintaducentillion" " tresquinquagintaducentillion" " quattuorquinquagintaducentillion" " quinquaquinquagintaducentillion" " sesquinquagintaducentillion" " septenquinquagintaducentillion" " octoquinquagintaducentillion" " novenquinquagintaducentillion" " sexagintaducentillion" " unsexagintaducentillion" " duosexagintaducentillion" " tresexagintaducentillion" " quattuorsexagintaducentillion" " quinquasexagintaducentillion" " sesexagintaducentillion" " septensexagintaducentillion" " octosexagintaducentillion" " novensexagintaducentillion" " septuagintaducentillion" " unseptuagintaducentillion" " duoseptuagintaducentillion" " treseptuagintaducentillion" " quattuorseptuagintaducentillion" " quinquaseptuagintaducentillion" " seseptuagintaducentillion" " septenseptuagintaducentillion" " octoseptuagintaducentillion" " novenseptuagintaducentillion" " octogintaducentillion" " unoctogintaducentillion" " duooctogintaducentillion" " tresoctogintaducentillion" " quattuoroctogintaducentillion" " quinquaoctogintaducentillion" " sexoctogintaducentillion" " septemoctogintaducentillion" " octooctogintaducentillion" " novemoctogintaducentillion" " nonagintaducentillion" " unnonagintaducentillion" " duononagintaducentillion" " trenonagintaducentillion" " quattuornonagintaducentillion" " quinquanonagintaducentillion" " senonagintaducentillion" " septenonagintaducentillion" " octononagintaducentillion" " novenonagintaducentillion" " trecentillion" " untrecentillion" " duotrecentillion" " trestrecentillion" " quattuortrecentillion" " quinquatrecentillion" " sestrecentillion" " septentrecentillion" " octotrecentillion" " noventrecentillion" " decitrecentillion" " undecitrecentillion" " duodecitrecentillion" " tredecitrecentillion" " quattuordecitrecentillion" " quinquadecitrecentillion" " sedecitrecentillion" " septendecitrecentillion" " octodecitrecentillion" " novendecitrecentillion" " vigintitrecentillion" " unvigintitrecentillion" " duovigintitrecentillion" " tresvigintitrecentillion" " quattuorvigintitrecentillion" " quinquavigintitrecentillion" " sesvigintitrecentillion" " septemvigintitrecentillion" " octovigintitrecentillion" " novemvigintitrecentillion" " trigintatrecentillion" " untrigintatrecentillion" " duotrigintatrecentillion" " trestrigintatrecentillion" " quattuortrigintatrecentillion" " quinquatrigintatrecentillion" " sestrigintatrecentillion" " septentrigintatrecentillion" " octotrigintatrecentillion" " noventrigintatrecentillion" " quadragintatrecentillion" " unquadragintatrecentillion" " duoquadragintatrecentillion" " tresquadragintatrecentillion" " quattuorquadragintatrecentillion" " quinquaquadragintatrecentillion" " sesquadragintatrecentillion" " septenquadragintatrecentillion" " octoquadragintatrecentillion" " novenquadragintatrecentillion" " quinquagintatrecentillion" " unquinquagintatrecentillion" " duoquinquagintatrecentillion" " tresquinquagintatrecentillion" " quattuorquinquagintatrecentillion" " quinquaquinquagintatrecentillion" " sesquinquagintatrecentillion" " septenquinquagintatrecentillion" " octoquinquagintatrecentillion" " novenquinquagintatrecentillion" " sexagintatrecentillion" " unsexagintatrecentillion" " duosexagintatrecentillion" " tresexagintatrecentillion" " quattuorsexagintatrecentillion" " quinquasexagintatrecentillion" " sesexagintatrecentillion" " septensexagintatrecentillion" " octosexagintatrecentillion" " novensexagintatrecentillion" " septuagintatrecentillion" " unseptuagintatrecentillion" " duoseptuagintatrecentillion" " treseptuagintatrecentillion" " quattuorseptuagintatrecentillion" " quinquaseptuagintatrecentillion" " seseptuagintatrecentillion" " septenseptuagintatrecentillion" " octoseptuagintatrecentillion" " novenseptuagintatrecentillion" " octogintatrecentillion" " unoctogintatrecentillion" " duooctogintatrecentillion" " tresoctogintatrecentillion" " quattuoroctogintatrecentillion" " quinquaoctogintatrecentillion" " sexoctogintatrecentillion" " septemoctogintatrecentillion" " octooctogintatrecentillion" " novemoctogintatrecentillion" " nonagintatrecentillion" " unnonagintatrecentillion" " duononagintatrecentillion" " trenonagintatrecentillion" " quattuornonagintatrecentillion" " quinquanonagintatrecentillion" " senonagintatrecentillion" " septenonagintatrecentillion" " octononagintatrecentillion" " novenonagintatrecentillion" " quadringentillion" " unquadringentillion" " duoquadringentillion" " tresquadringentillion" " quattuorquadringentillion" " quinquaquadringentillion" " sesquadringentillion" " septenquadringentillion" " octoquadringentillion" " novenquadringentillion" " deciquadringentillion" " undeciquadringentillion" " duodeciquadringentillion" " tredeciquadringentillion" " quattuordeciquadringentillion" " quinquadeciquadringentillion" " sedeciquadringentillion" " septendeciquadringentillion" " octodeciquadringentillion" " novendeciquadringentillion" " vigintiquadringentillion" " unvigintiquadringentillion" " duovigintiquadringentillion" " tresvigintiquadringentillion" " quattuorvigintiquadringentillion" " quinquavigintiquadringentillion" " sesvigintiquadringentillion" " septemvigintiquadringentillion" " octovigintiquadringentillion" " novemvigintiquadringentillion" " trigintaquadringentillion" " untrigintaquadringentillion" " duotrigintaquadringentillion" " trestrigintaquadringentillion" " quattuortrigintaquadringentillion" " quinquatrigintaquadringentillion" " sestrigintaquadringentillion" " septentrigintaquadringentillion" " octotrigintaquadringentillion" " noventrigintaquadringentillion" " quadragintaquadringentillion" " unquadragintaquadringentillion" " duoquadragintaquadringentillion" " tresquadragintaquadringentillion" " quattuorquadragintaquadringentillion" " quinquaquadragintaquadringentillion" " sesquadragintaquadringentillion" " septenquadragintaquadringentillion" " octoquadragintaquadringentillion" " novenquadragintaquadringentillion" " quinquagintaquadringentillion" " unquinquagintaquadringentillion" " duoquinquagintaquadringentillion" " tresquinquagintaquadringentillion" " quattuorquinquagintaquadringentillion" " quinquaquinquagintaquadringentillion" " sesquinquagintaquadringentillion" " septenquinquagintaquadringentillion" " octoquinquagintaquadringentillion" " novenquinquagintaquadringentillion" " sexagintaquadringentillion" " unsexagintaquadringentillion" " duosexagintaquadringentillion" " tresexagintaquadringentillion" " quattuorsexagintaquadringentillion" " quinquasexagintaquadringentillion" " sesexagintaquadringentillion" " septensexagintaquadringentillion" " octosexagintaquadringentillion" " novensexagintaquadringentillion" " septuagintaquadringentillion" " unseptuagintaquadringentillion" " duoseptuagintaquadringentillion" " treseptuagintaquadringentillion" " quattuorseptuagintaquadringentillion" " quinquaseptuagintaquadringentillion" " seseptuagintaquadringentillion" " septenseptuagintaquadringentillion" " octoseptuagintaquadringentillion" " novenseptuagintaquadringentillion" " octogintaquadringentillion" " unoctogintaquadringentillion" " duooctogintaquadringentillion" " tresoctogintaquadringentillion" " quattuoroctogintaquadringentillion" " quinquaoctogintaquadringentillion" " sexoctogintaquadringentillion" " septemoctogintaquadringentillion" " octooctogintaquadringentillion" " novemoctogintaquadringentillion" " nonagintaquadringentillion" " unnonagintaquadringentillion" " duononagintaquadringentillion" " trenonagintaquadringentillion" " quattuornonagintaquadringentillion" " quinquanonagintaquadringentillion" " senonagintaquadringentillion" " septenonagintaquadringentillion" " octononagintaquadringentillion" " novenonagintaquadringentillion" " quingentillion" " unquingentillion" " duoquingentillion" " tresquingentillion" " quattuorquingentillion" " quinquaquingentillion" " sesquingentillion" " septenquingentillion" " octoquingentillion" " novenquingentillion" " deciquingentillion" " undeciquingentillion" " duodeciquingentillion" " tredeciquingentillion" " quattuordeciquingentillion" " quinquadeciquingentillion" " sedeciquingentillion" " septendeciquingentillion" " octodeciquingentillion" " novendeciquingentillion" " vigintiquingentillion" " unvigintiquingentillion" " duovigintiquingentillion" " tresvigintiquingentillion" " quattuorvigintiquingentillion" " quinquavigintiquingentillion" " sesvigintiquingentillion" " septemvigintiquingentillion" " octovigintiquingentillion" " novemvigintiquingentillion" " trigintaquingentillion" " untrigintaquingentillion" " duotrigintaquingentillion" " trestrigintaquingentillion" " quattuortrigintaquingentillion" " quinquatrigintaquingentillion" " sestrigintaquingentillion" " septentrigintaquingentillion" " octotrigintaquingentillion" " noventrigintaquingentillion" " quadragintaquingentillion" " unquadragintaquingentillion" " duoquadragintaquingentillion" " tresquadragintaquingentillion" " quattuorquadragintaquingentillion" " quinquaquadragintaquingentillion" " sesquadragintaquingentillion" " septenquadragintaquingentillion" " octoquadragintaquingentillion" " novenquadragintaquingentillion" " quinquagintaquingentillion" " unquinquagintaquingentillion" " duoquinquagintaquingentillion" " tresquinquagintaquingentillion" " quattuorquinquagintaquingentillion" " quinquaquinquagintaquingentillion" " sesquinquagintaquingentillion" " septenquinquagintaquingentillion" " octoquinquagintaquingentillion" " novenquinquagintaquingentillion" " sexagintaquingentillion" " unsexagintaquingentillion" " duosexagintaquingentillion" " tresexagintaquingentillion" " quattuorsexagintaquingentillion" " quinquasexagintaquingentillion" " sesexagintaquingentillion" " septensexagintaquingentillion" " octosexagintaquingentillion" " novensexagintaquingentillion" " septuagintaquingentillion" " unseptuagintaquingentillion" " duoseptuagintaquingentillion" " treseptuagintaquingentillion" " quattuorseptuagintaquingentillion" " quinquaseptuagintaquingentillion" " seseptuagintaquingentillion" " septenseptuagintaquingentillion" " octoseptuagintaquingentillion" " novenseptuagintaquingentillion" " octogintaquingentillion" " unoctogintaquingentillion" " duooctogintaquingentillion" " tresoctogintaquingentillion" " quattuoroctogintaquingentillion" " quinquaoctogintaquingentillion" " sexoctogintaquingentillion" " septemoctogintaquingentillion" " octooctogintaquingentillion" " novemoctogintaquingentillion" " nonagintaquingentillion" " unnonagintaquingentillion" " duononagintaquingentillion" " trenonagintaquingentillion" " quattuornonagintaquingentillion" " quinquanonagintaquingentillion" " senonagintaquingentillion" " septenonagintaquingentillion" " octononagintaquingentillion" " novenonagintaquingentillion" " sescentillion" " unsescentillion" " duosescentillion" " tresescentillion" " quattuorsescentillion" " quinquasescentillion" " sesescentillion" " septensescentillion" " octosescentillion" " novensescentillion" " decisescentillion" " undecisescentillion" " duodecisescentillion" " tredecisescentillion" " quattuordecisescentillion" " quinquadecisescentillion" " sedecisescentillion" " septendecisescentillion" " octodecisescentillion" " novendecisescentillion" " vigintisescentillion" " unvigintisescentillion" " duovigintisescentillion" " tresvigintisescentillion" " quattuorvigintisescentillion" " quinquavigintisescentillion" " sesvigintisescentillion" " septemvigintisescentillion" " octovigintisescentillion" " novemvigintisescentillion" " trigintasescentillion" " untrigintasescentillion" " duotrigintasescentillion" " trestrigintasescentillion" " quattuortrigintasescentillion" " quinquatrigintasescentillion" " sestrigintasescentillion" " septentrigintasescentillion" " octotrigintasescentillion" " noventrigintasescentillion" " quadragintasescentillion" " unquadragintasescentillion" " duoquadragintasescentillion" " tresquadragintasescentillion" " quattuorquadragintasescentillion" " quinquaquadragintasescentillion" " sesquadragintasescentillion" " septenquadragintasescentillion" " octoquadragintasescentillion" " novenquadragintasescentillion" " quinquagintasescentillion" " unquinquagintasescentillion" " duoquinquagintasescentillion" " tresquinquagintasescentillion" " quattuorquinquagintasescentillion" " quinquaquinquagintasescentillion" " sesquinquagintasescentillion" " septenquinquagintasescentillion" " octoquinquagintasescentillion" " novenquinquagintasescentillion" " sexagintasescentillion" " unsexagintasescentillion" " duosexagintasescentillion" " tresexagintasescentillion" " quattuorsexagintasescentillion" " quinquasexagintasescentillion" " sesexagintasescentillion" " septensexagintasescentillion" " octosexagintasescentillion" " novensexagintasescentillion" " septuagintasescentillion" " unseptuagintasescentillion" " duoseptuagintasescentillion" " treseptuagintasescentillion" " quattuorseptuagintasescentillion" " quinquaseptuagintasescentillion" " seseptuagintasescentillion" " septenseptuagintasescentillion" " octoseptuagintasescentillion" " novenseptuagintasescentillion" " octogintasescentillion" " unoctogintasescentillion" " duooctogintasescentillion" " tresoctogintasescentillion" " quattuoroctogintasescentillion" " quinquaoctogintasescentillion" " sexoctogintasescentillion" " septemoctogintasescentillion" " octooctogintasescentillion" " novemoctogintasescentillion" " nonagintasescentillion" " unnonagintasescentillion" " duononagintasescentillion" " trenonagintasescentillion" " quattuornonagintasescentillion" " quinquanonagintasescentillion" " senonagintasescentillion" " septenonagintasescentillion" " octononagintasescentillion" " novenonagintasescentillion" " septingentillion" " unseptingentillion" " duoseptingentillion" " treseptingentillion" " quattuorseptingentillion" " quinquaseptingentillion" " seseptingentillion" " septenseptingentillion" " octoseptingentillion" " novenseptingentillion" " deciseptingentillion" " undeciseptingentillion" " duodeciseptingentillion" " tredeciseptingentillion" " quattuordeciseptingentillion" " quinquadeciseptingentillion" " sedeciseptingentillion" " septendeciseptingentillion" " octodeciseptingentillion" " novendeciseptingentillion" " vigintiseptingentillion" " unvigintiseptingentillion" " duovigintiseptingentillion" " tresvigintiseptingentillion" " quattuorvigintiseptingentillion" " quinquavigintiseptingentillion" " sesvigintiseptingentillion" " septemvigintiseptingentillion" " octovigintiseptingentillion" " novemvigintiseptingentillion" " trigintaseptingentillion" " untrigintaseptingentillion" " duotrigintaseptingentillion" " trestrigintaseptingentillion" " quattuortrigintaseptingentillion" " quinquatrigintaseptingentillion" " sestrigintaseptingentillion" " septentrigintaseptingentillion" " octotrigintaseptingentillion" " noventrigintaseptingentillion" " quadragintaseptingentillion" " unquadragintaseptingentillion" " duoquadragintaseptingentillion" " tresquadragintaseptingentillion" " quattuorquadragintaseptingentillion" " quinquaquadragintaseptingentillion" " sesquadragintaseptingentillion" " septenquadragintaseptingentillion" " octoquadragintaseptingentillion" " novenquadragintaseptingentillion" " quinquagintaseptingentillion" " unquinquagintaseptingentillion" " duoquinquagintaseptingentillion" " tresquinquagintaseptingentillion" " quattuorquinquagintaseptingentillion" " quinquaquinquagintaseptingentillion" " sesquinquagintaseptingentillion" " septenquinquagintaseptingentillion" " octoquinquagintaseptingentillion" " novenquinquagintaseptingentillion" " sexagintaseptingentillion" " unsexagintaseptingentillion" " duosexagintaseptingentillion" " tresexagintaseptingentillion" " quattuorsexagintaseptingentillion" " quinquasexagintaseptingentillion" " sesexagintaseptingentillion" " septensexagintaseptingentillion" " octosexagintaseptingentillion" " novensexagintaseptingentillion" " septuagintaseptingentillion" " unseptuagintaseptingentillion" " duoseptuagintaseptingentillion" " treseptuagintaseptingentillion" " quattuorseptuagintaseptingentillion" " quinquaseptuagintaseptingentillion" " seseptuagintaseptingentillion" " septenseptuagintaseptingentillion" " octoseptuagintaseptingentillion" " novenseptuagintaseptingentillion" " octogintaseptingentillion" " unoctogintaseptingentillion" " duooctogintaseptingentillion" " tresoctogintaseptingentillion" " quattuoroctogintaseptingentillion" " quinquaoctogintaseptingentillion" " sexoctogintaseptingentillion" " septemoctogintaseptingentillion" " octooctogintaseptingentillion" " novemoctogintaseptingentillion" " nonagintaseptingentillion" " unnonagintaseptingentillion" " duononagintaseptingentillion" " trenonagintaseptingentillion" " quattuornonagintaseptingentillion" " quinquanonagintaseptingentillion" " senonagintaseptingentillion" " septenonagintaseptingentillion" " octononagintaseptingentillion" " novenonagintaseptingentillion" " octingentillion" " unoctingentillion" " duooctingentillion" " tresoctingentillion" " quattuoroctingentillion" " quinquaoctingentillion" " sexoctingentillion" " septemoctingentillion" " octooctingentillion" " novemoctingentillion" " decioctingentillion" " undecioctingentillion" " duodecioctingentillion" " tredecioctingentillion" " quattuordecioctingentillion" " quinquadecioctingentillion" " sedecioctingentillion" " septendecioctingentillion" " octodecioctingentillion" " novendecioctingentillion" " vigintioctingentillion" " unvigintioctingentillion" " duovigintioctingentillion" " tresvigintioctingentillion" " quattuorvigintioctingentillion" " quinquavigintioctingentillion" " sesvigintioctingentillion" " septemvigintioctingentillion" " octovigintioctingentillion" " novemvigintioctingentillion" " trigintaoctingentillion" " untrigintaoctingentillion" " duotrigintaoctingentillion" " trestrigintaoctingentillion" " quattuortrigintaoctingentillion" " quinquatrigintaoctingentillion" " sestrigintaoctingentillion" " septentrigintaoctingentillion" " octotrigintaoctingentillion" " noventrigintaoctingentillion" " quadragintaoctingentillion" " unquadragintaoctingentillion" " duoquadragintaoctingentillion" " tresquadragintaoctingentillion" " quattuorquadragintaoctingentillion" " quinquaquadragintaoctingentillion" " sesquadragintaoctingentillion" " septenquadragintaoctingentillion" " octoquadragintaoctingentillion" " novenquadragintaoctingentillion" " quinquagintaoctingentillion" " unquinquagintaoctingentillion" " duoquinquagintaoctingentillion" " tresquinquagintaoctingentillion" " quattuorquinquagintaoctingentillion" " quinquaquinquagintaoctingentillion" " sesquinquagintaoctingentillion" " septenquinquagintaoctingentillion" " octoquinquagintaoctingentillion" " novenquinquagintaoctingentillion" " sexagintaoctingentillion" " unsexagintaoctingentillion" " duosexagintaoctingentillion" " tresexagintaoctingentillion" " quattuorsexagintaoctingentillion" " quinquasexagintaoctingentillion" " sesexagintaoctingentillion" " septensexagintaoctingentillion" " octosexagintaoctingentillion" " novensexagintaoctingentillion" " septuagintaoctingentillion" " unseptuagintaoctingentillion" " duoseptuagintaoctingentillion" " treseptuagintaoctingentillion" " quattuorseptuagintaoctingentillion" " quinquaseptuagintaoctingentillion" " seseptuagintaoctingentillion" " septenseptuagintaoctingentillion" " octoseptuagintaoctingentillion" " novenseptuagintaoctingentillion" " octogintaoctingentillion" " unoctogintaoctingentillion" " duooctogintaoctingentillion" " tresoctogintaoctingentillion" " quattuoroctogintaoctingentillion" " quinquaoctogintaoctingentillion" " sexoctogintaoctingentillion" " septemoctogintaoctingentillion" " octooctogintaoctingentillion" " novemoctogintaoctingentillion" " nonagintaoctingentillion" " unnonagintaoctingentillion" " duononagintaoctingentillion" " trenonagintaoctingentillion" " quattuornonagintaoctingentillion" " quinquanonagintaoctingentillion" " senonagintaoctingentillion" " septenonagintaoctingentillion" " octononagintaoctingentillion" " novenonagintaoctingentillion" " nongentillion" " unnongentillion" " duonongentillion" " trenongentillion" " quattuornongentillion" " quinquanongentillion" " senongentillion" " septenongentillion" " octonongentillion" " novenongentillion" " decinongentillion" " undecinongentillion" " duodecinongentillion" " tredecinongentillion" " quattuordecinongentillion" " quinquadecinongentillion" " sedecinongentillion" " septendecinongentillion" " octodecinongentillion" " novendecinongentillion" " vigintinongentillion" " unvigintinongentillion" " duovigintinongentillion" " tresvigintinongentillion" " quattuorvigintinongentillion" " quinquavigintinongentillion" " sesvigintinongentillion" " septemvigintinongentillion" " octovigintinongentillion" " novemvigintinongentillion" " trigintanongentillion" " untrigintanongentillion" " duotrigintanongentillion" " trestrigintanongentillion" " quattuortrigintanongentillion" " quinquatrigintanongentillion" " sestrigintanongentillion" " septentrigintanongentillion" " octotrigintanongentillion" " noventrigintanongentillion" " quadragintanongentillion" " unquadragintanongentillion" " duoquadragintanongentillion" " tresquadragintanongentillion" " quattuorquadragintanongentillion" " quinquaquadragintanongentillion" " sesquadragintanongentillion" " septenquadragintanongentillion" " octoquadragintanongentillion" " novenquadragintanongentillion" " quinquagintanongentillion" " unquinquagintanongentillion" " duoquinquagintanongentillion" " tresquinquagintanongentillion" " quattuorquinquagintanongentillion" " quinquaquinquagintanongentillion" " sesquinquagintanongentillion" " septenquinquagintanongentillion" " octoquinquagintanongentillion" " novenquinquagintanongentillion" " sexagintanongentillion" " unsexagintanongentillion" " duosexagintanongentillion" " tresexagintanongentillion" " quattuorsexagintanongentillion" " quinquasexagintanongentillion" " sesexagintanongentillion" " septensexagintanongentillion" " octosexagintanongentillion" " novensexagintanongentillion" " septuagintanongentillion" " unseptuagintanongentillion" " duoseptuagintanongentillion" " treseptuagintanongentillion" " quattuorseptuagintanongentillion" " quinquaseptuagintanongentillion" " seseptuagintanongentillion" " septenseptuagintanongentillion" " octoseptuagintanongentillion" " novenseptuagintanongentillion" " octogintanongentillion" " unoctogintanongentillion" " duooctogintanongentillion" " tresoctogintanongentillion" " quattuoroctogintanongentillion" " quinquaoctogintanongentillion" " sexoctogintanongentillion" " septemoctogintanongentillion" " octooctogintanongentillion" " novemoctogintanongentillion" " nonagintanongentillion" " unnonagintanongentillion" " duononagintanongentillion" " trenonagintanongentillion" " quattuornonagintanongentillion" " quinquanonagintanongentillion" " senonagintanongentillion" " septenonagintanongentillion" " octononagintanongentillion" " novenonagintanongentillion")) (defconstant ordinal-ones #(nil "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth") "Table of ordinal ones-place digits in English") (defconstant ordinal-tens #(nil "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") "Table of ordinal tens-place digits in English") (defun format-print-small-cardinal (stream n) (multiple-value-bind (hundreds rem) (truncate n 100) (when (plusp hundreds) (write-string (svref cardinal-ones hundreds) stream) (write-string " hundred" stream) (when (plusp rem) (write-char #\space stream))) (when (plusp rem) (multiple-value-bind (tens ones) (truncate rem 10) (cond ((< 1 tens) (write-string (svref cardinal-tens tens) stream) (when (plusp ones) (write-char #\- stream) (write-string (svref cardinal-ones ones) stream))) ((= tens 1) (write-string (svref cardinal-teens ones) stream)) ((plusp ones) (write-string (svref cardinal-ones ones) stream))))))) (defun format-print-cardinal (stream n) (cond ((minusp n) (write-string "negative " stream) (format-print-cardinal-aux stream (- n) 0 n)) ((zerop n) (write-string "zero" stream)) (t (format-print-cardinal-aux stream n 0 n)))) (defun format-print-cardinal-aux (stream n period err) (multiple-value-bind (beyond here) (truncate n 1000) (unless (< period (length cardinal-periods)) (error "Number too large to print in English: ~:D" err)) (unless (zerop beyond) (format-print-cardinal-aux stream beyond (1+ period) err)) (unless (zerop here) (unless (zerop beyond) (write-char #\space stream)) (format-print-small-cardinal stream here) (write-string (svref cardinal-periods period) stream)))) (defun format-print-ordinal (stream n) (when (minusp n) (write-string "negative " stream)) (let ((number (abs n))) (multiple-value-bind (top bot) (truncate number 100) (unless (zerop top) (format-print-cardinal stream (- number bot))) (when (and (plusp top) (plusp bot)) (write-char #\space stream)) (multiple-value-bind (tens ones) (truncate bot 10) (cond ((= bot 12) (write-string "twelfth" stream)) ((= tens 1) (write-string (svref cardinal-teens ones) stream);;;RAD (write-string "th" stream)) ((and (zerop tens) (plusp ones)) (write-string (svref ordinal-ones ones) stream)) ((and (zerop ones)(plusp tens)) (write-string (svref ordinal-tens tens) stream)) ((plusp bot) (write-string (svref cardinal-tens tens) stream) (write-char #\- stream) (write-string (svref ordinal-ones ones) stream)) ((plusp number) (write-string "th" stream)) (t (write-string "zeroth" stream))))))) ;;; Print Roman numerals (defun format-print-old-roman (stream n) (unless (< 0 n 5000) (error (intl:gettext "Number too large to print in old Roman numerals: ~:D") n)) (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) (val-list '(500 100 50 10 5 1) (cdr val-list)) (cur-char #\M (car char-list)) (cur-val 1000 (car val-list)) (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) ((< i cur-val) i)))) ((zerop start)))) (defun format-print-roman (stream n) (unless (< 0 n 4000) (error (intl:gettext "Number too large to print in Roman numerals: ~:D") n)) (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) (val-list '(500 100 50 10 5 1) (cdr val-list)) (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) (sub-val '(100 10 10 1 1 0) (cdr sub-val)) (cur-char #\M (car char-list)) (cur-val 1000 (car val-list)) (cur-sub-char #\C (car sub-chars)) (cur-sub-val 100 (car sub-val)) (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) ((< i cur-val) (cond ((<= (- cur-val cur-sub-val) i) (write-char cur-sub-char stream) (write-char cur-char stream) (- i (- cur-val cur-sub-val))) (t i)))))) ((zerop start)))) ;;;; Plural. (def-format-directive #\P (colonp atsignp params end) (expand-bind-defaults () params (let ((arg (cond ((not colonp) (expand-next-arg)) (*orig-args-available* `(if (eq orig-args args) (error 'format-error :complaint (intl:gettext "No previous argument.") :offset ,(1- end)) (do ((arg-ptr orig-args (cdr arg-ptr))) ((eq (cdr arg-ptr) args) (car arg-ptr))))) (*only-simple-args* (unless *simple-args* (error 'format-error :complaint (intl:gettext "No previous argument."))) (caar *simple-args*)) (t (throw 'need-orig-args nil))))) (if atsignp `(write-string (if (eql ,arg 1) "y" "ies") stream) `(unless (eql ,arg 1) (write-char #\s stream)))))) (def-format-interpreter #\P (colonp atsignp params) (interpret-bind-defaults () params (let ((arg (if colonp (if (eq orig-args args) (error 'format-error :complaint "No previous argument.") (do ((arg-ptr orig-args (cdr arg-ptr))) ((eq (cdr arg-ptr) args) (car arg-ptr)))) (next-arg)))) (if atsignp (write-string (if (eql arg 1) "y" "ies") stream) (unless (eql arg 1) (write-char #\s stream)))))) ;;;; Floating point noise. (defun decimal-string (n) (write-to-string n :base 10 :radix nil :escape nil)) (def-format-directive #\F (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) (def-format-interpreter #\F (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params (format-fixed stream (next-arg) w d k ovf pad atsignp))) (defun format-fixed (stream number w d k ovf pad atsign) (if (numberp number) (if (floatp number) (format-fixed-aux stream number w d k ovf pad atsign) (if (rationalp number) (format-fixed-aux stream (coerce number 'single-float) w d k ovf pad atsign) (format-write-field stream (decimal-string number) w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) ;;; We return true if we overflowed, so that ~G can output the overflow char ;;; instead of spaces. ;;; (defun format-fixed-aux (stream number w d k ovf pad atsign) (declare (type float number)) (cond ((and (floatp number) (or (float-infinity-p number) (float-nan-p number))) (prin1 number stream) nil) (t (let ((spaceleft w)) (when (and w (or atsign (minusp (float-sign number)))) (decf spaceleft)) (multiple-value-bind (str len lpoint tpoint) (lisp::flonum-to-string (abs number) :width spaceleft :fdigits d :scale k :allow-overflow-p nil) ;;if caller specifically requested no fraction digits, suppress the ;;optional trailing zero (when (and d (zerop d)) (setq tpoint nil)) (when w (decf spaceleft len) ;;optional leading zero (when lpoint (if (or (> spaceleft 0) tpoint) ;force at least one digit (decf spaceleft) (setq lpoint nil))) ;;optional trailing zero (when tpoint (if (> spaceleft 0) (decf spaceleft) (setq tpoint nil)))) (cond ((and w (< spaceleft 0) ovf) ;;field width overflow (dotimes (i w) (write-char ovf stream)) t) (t (when w (dotimes (i spaceleft) (write-char pad stream))) (if (minusp (float-sign number)) (write-char #\- stream) (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) (write-string str stream) (when tpoint (write-char #\0 stream)) nil))))))) (def-format-directive #\E (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (expand-bind-defaults ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) params `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) (def-format-interpreter #\E (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (interpret-bind-defaults ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) params (format-exponential stream (next-arg) w d e k ovf pad mark atsignp))) (defun format-exponential (stream number w d e k ovf pad marker atsign) (if (numberp number) (if (floatp number) (format-exp-aux stream number w d e k ovf pad marker atsign) (if (rationalp number) (format-exp-aux stream (coerce number 'single-float) w d e k ovf pad marker atsign) (format-write-field stream (decimal-string number) w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) (defun format-exponent-marker (number) (if (typep number *read-default-float-format*) #\e (typecase number (single-float #\f) (double-float #\d) (short-float #\s) (long-float #\l) #+double-double (double-double-float #\w)))) ;; This is a modified version of scale in FLONUM-TO-DIGITS. We only ;; want the exponent, so most things not needed for the computation of ;; the exponent has been removed. We also implemented the ;; floating-point log approximation given in Burger and Dybvig. This ;; is very noticeably faster for large and small numbers. It is ;; slower for intermediate sized numbers. (defun accurate-scale-exponent (v) (declare (type float v)) (if (zerop v) 1 (let ((float-radix 2) ; b (float-digits (float-digits v)) ; p (min-e (etypecase v (single-float lisp::single-float-min-e) (double-float lisp::double-float-min-e) #+double-double (double-double-float lisp::double-double-float-min-e)))) (multiple-value-bind (f e) (integer-decode-float v) (let ( ;; FIXME: these even tests assume normal IEEE rounding ;; mode. I wonder if we should cater for non-normal? (high-ok (evenp f))) ;; This scale function is basically the same as the one in ;; FLONUM-TO-DIGITS, except we don't return the computed ;; digits. We only want the exponent. (labels ((flog (x) (declare (type (float (0.0)) x)) (let ((xd (etypecase x (single-float (float x 1d0)) (double-float x) #+double-double (double-double-float (double-double-hi x))))) (ceiling (- (the (double-float -400d0 400d0) (log xd 10d0)) 1d-10)))) (fixup (r s m+ k) (if (if high-ok (>= (+ r m+) s) (> (+ r m+) s)) (+ k 1) k)) (scale (r s m+) (let* ((est (flog v)) (scale (the integer (aref lisp::*powers-of-ten* (abs est))))) (if (>= est 0) (fixup r (* s scale) m+ est) (fixup (* r scale) s (* m+ scale) est))))) (let (r s m+) (if (>= e 0) (let* ((be (expt float-radix e)) (be1 (* be float-radix))) (if (/= f (expt float-radix (1- float-digits))) (setf r (* f be 2) s 2 m+ be) (setf r (* f be1 2) s (* float-radix 2) m+ be1))) (if (or (= e min-e) (/= f (expt float-radix (1- float-digits)))) (setf r (* f 2) s (* (expt float-radix (- e)) 2) m+ 1) (setf r (* f float-radix 2) s (* (expt float-radix (- 1 e)) 2) m+ float-radix))) (scale r s m+)))))))) ;;;Here we prevent the scale factor from shifting all significance out of ;;;a number to the right. We allow insignificant zeroes to be shifted in ;;;to the left right, athough it is an error to specify k and d such that this ;;;occurs. Perhaps we should detect both these conditions and flag them as ;;;errors. As for now, we let the user get away with it, and merely guarantee ;;;that at least one significant digit will appear. ;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent ;;; marker is always printed. Make it so. Also, the original version ;;; causes errors when printing infinities or NaN's. The Hyperspec is ;;; silent here, so let's just print out infinities and NaN's instead ;;; of causing an error. (defun format-exp-aux (stream number w d e k ovf pad marker atsign) (if (and (floatp number) (or (float-infinity-p number) (float-nan-p number))) (prin1 number stream) (let* ((num-expt (accurate-scale-exponent (abs number))) (expt (if (zerop number) 0 (- num-expt k))) (estr (decimal-string (abs expt))) (elen (if e (max (length estr) e) (length estr))) (add-zero-p nil)) (if (and w ovf e (> elen e)) ;exponent overflow (dotimes (i w) (write-char ovf stream)) ;; The hairy case (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) (fmin (if (minusp k) 1 fdig)) (spaceleft (if w (- w 2 elen (if (or atsign (minusp (float-sign number))) 1 0)) nil))) #+(or) (progn (format t "fdig = ~A~%" fdig) (format t "fmin = ~A~%" fmin) (format t "spaceleft = ~A~%" spaceleft) (format t "expt = ~S~%" expt)) (multiple-value-bind (fstr flen lpoint tpoint point-pos roundoff) (lisp::flonum-to-string (abs number) :width spaceleft :fdigits fdig :scale k :fmin fmin :num-expt num-expt) (declare (ignore point-pos)) #+(or) (progn (format t "fstr = ~S~%" fstr) (format t "flen = ~S~%" flen) (format t "lp = ~S~%" lpoint) (format t "tp = ~S~%" tpoint)) (when (and d (zerop d)) (setq tpoint nil)) (when w (decf spaceleft flen) ;; See CLHS 22.3.3.2. "If the parameter d is ;; omitted, ... [and] if the fraction to be ;; printed is zero then a single zero digit should ;; appear after the decimal point." So we need to ;; subtract one from here because we're going to ;; add an extra 0 digit later. (when (and (null d) (char= (aref fstr (1- flen)) #\.)) (setf add-zero-p t) (decf spaceleft)) (when lpoint (if (or (> spaceleft 0) tpoint) (decf spaceleft) (setq lpoint nil))) (when (and tpoint (<= spaceleft 0)) (setq tpoint nil))) (cond ((and w (< spaceleft 0) ovf) ;;significand overflow (dotimes (i w) (write-char ovf stream))) (t (when w (dotimes (i spaceleft) (write-char pad stream))) (if (minusp (float-sign number)) (write-char #\- stream) (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) (write-string fstr stream) ;; Add a zero if we need it. Which means ;; we figured out we need one above, or ;; another condition. Basically, append a ;; zero if there are no width constraints ;; and if the last char to print was a ;; decimal (so the trailing fraction is ;; zero.) (when (or add-zero-p (and (null w) (char= (aref fstr (1- flen)) #\.))) ;; It's later and we're adding the zero ;; digit. (write-char #\0 stream)) (write-char (if marker marker (format-exponent-marker number)) stream) (when roundoff ;; Printed result has rounded the number up ;; so that the exponent is one too small. ;; Increase our printed exponent. (incf expt) (setf estr (decimal-string (abs expt)))) (write-char (if (minusp expt) #\- #\+) stream) (when e ;;zero-fill before exponent if necessary (dotimes (i (- e (length estr))) (write-char #\0 stream))) (write-string estr stream)))))))) (values)) (def-format-directive #\G (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (expand-bind-defaults ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) params `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) (def-format-interpreter #\G (colonp atsignp params) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier with this directive."))) (interpret-bind-defaults ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) params (format-general stream (next-arg) w d e k ovf pad mark atsignp))) (defun format-general (stream number w d e k ovf pad marker atsign) (if (numberp number) (if (floatp number) (format-general-aux stream number w d e k ovf pad marker atsign) (if (rationalp number) (format-general-aux stream (coerce number 'single-float) w d e k ovf pad marker atsign) (format-write-field stream (decimal-string number) w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) ;;; toy@rtp.ericsson.se: Same change as for format-exp-aux. (defun format-general-aux (stream number w d e k ovf pad marker atsign) (if (and (floatp number) (or (float-infinity-p number) (float-nan-p number))) (prin1 number stream) (let* ((n (accurate-scale-exponent (abs number))) (orig-d d)) ;; Default d if omitted. The procedure is taken directly from ;; the definition given in the manual (CLHS 22.3.3.3), and is ;; not very efficient, since we generate the digits twice. ;; Future maintainers are encouraged to improve on this. ;; ;; It's also not very clear whether q in the spec is the ;; number of significant digits or not. I (rtoy) think it ;; makes more sense if q is the number of significant digits. ;; That way 1d300 isn't printed as 1 followed by 300 zeroes. ;; Exponential notation would be used instead. (unless d ;; flonum-to-digits doesn't like 0.0, so handle the special ;; case here. Set d to n so that dd = 0 <= d to use ~F ;; format. (if (zerop number) (setq d n) (let* ((q (length (nth-value 1 (lisp::flonum-to-digits (abs number)))))) (setq d (max q (min n 7)))))) (let* ((ee (if e (+ e 2) 4)) (ww (if w (- w ee) nil)) (dd (- d n))) #+(or) (progn (format t "d = ~A~%" d) (format t "ee = ~A~%" ee) (format t "ww = ~A~%" ww) (format t "dd = ~A~%" dd)) (cond ((<= 0 dd d) ;; Use dd fraction digits, even if that would cause ;; the width to be exceeded. We choose accuracy over ;; width in this case. (let* ((fill-char (if (format-fixed-aux stream number ww dd nil ovf pad atsign) ovf #\space))) (dotimes (i ee) (write-char fill-char stream)))) (t (format-exp-aux stream number w orig-d e (or k 1) ovf pad marker atsign))))))) (def-format-directive #\$ (colonp atsignp params) (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp ,atsignp))) (def-format-interpreter #\$ (colonp atsignp params) (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params (format-dollars stream (next-arg) d n w pad colonp atsignp))) (defun format-dollars (stream number d n w pad colon atsign) (if (rationalp number) (setq number (coerce number 'single-float))) (if (floatp number) (let* ((signstr (if (minusp (float-sign number)) "-" (if atsign "+" ""))) (signlen (length signstr))) (multiple-value-bind (str strlen ig2 ig3 pointplace) (lisp::flonum-to-string number :width nil :fdigits d :scale nil) (declare (ignore ig2 ig3)) (when colon (write-string signstr stream)) (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen)) (write-char pad stream)) (unless colon (write-string signstr stream)) (dotimes (i (- n pointplace)) (write-char #\0 stream)) (write-string str stream))) (format-write-field stream (decimal-string number) w 1 0 #\space t))) ;;;; line/page breaks and other stuff like that. (def-format-directive #\% (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (if params (expand-bind-defaults ((count 1)) params `(dotimes (i ,count) (terpri stream))) '(terpri stream))) (def-format-interpreter #\% (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (terpri stream)))) (def-format-directive #\& (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (if params (expand-bind-defaults ((count 1)) params `(progn (when (plusp ,count) (fresh-line stream) (dotimes (i (1- ,count)) (terpri stream))))) '(fresh-line stream))) (def-format-interpreter #\& (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (interpret-bind-defaults ((count 1)) params (when (plusp count) (fresh-line stream) (dotimes (i (1- count)) (terpri stream))))) (def-format-directive #\| (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (if params (expand-bind-defaults ((count 1)) params `(dotimes (i ,count) (write-char #\page stream))) '(write-char #\page stream))) (def-format-interpreter #\| (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (write-char #\page stream)))) (def-format-directive #\~ (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (if params (expand-bind-defaults ((count 1)) params `(dotimes (i ,count) (write-char #\~ stream))) '(write-char #\~ stream))) (def-format-interpreter #\~ (colonp atsignp params) (when (or colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify either colon or atsign for this directive."))) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (write-char #\~ stream)))) (def-complex-format-directive #\newline (colonp atsignp params directives) (when (and colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify both colon and atsign for this directive."))) (values (expand-bind-defaults () params (if atsignp '(write-char #\newline stream) nil)) (if (and (not colonp) directives (simple-string-p (car directives))) (cons (string-left-trim '(#\space #\newline #\tab) (car directives)) (cdr directives)) directives))) (def-complex-format-interpreter #\newline (colonp atsignp params directives) (when (and colonp atsignp) (error 'format-error :complaint (intl:gettext "Cannot specify both colon and atsign for this directive."))) (interpret-bind-defaults () params (when atsignp (write-char #\newline stream))) (if (and (not colonp) directives (simple-string-p (car directives))) (cons (string-left-trim '(#\space #\newline #\tab) (car directives)) (cdr directives)) directives)) ;;;; Tab and simple pretty-printing noise. (def-format-directive #\T (colonp atsignp params) (if colonp (expand-bind-defaults ((n 1) (m 1)) params `(pprint-tab ,(if atsignp :section-relative :section) ,n ,m stream)) (if atsignp (expand-bind-defaults ((colrel 1) (colinc 1)) params `(format-relative-tab stream ,colrel ,colinc)) (expand-bind-defaults ((colnum 1) (colinc 1)) params `(format-absolute-tab stream ,colnum ,colinc))))) (def-format-interpreter #\T (colonp atsignp params) (if colonp (interpret-bind-defaults ((n 1) (m 1)) params (pprint-tab (if atsignp :section-relative :section) n m stream)) (if atsignp (interpret-bind-defaults ((colrel 1) (colinc 1)) params (format-relative-tab stream colrel colinc)) (interpret-bind-defaults ((colnum 1) (colinc 1)) params (format-absolute-tab stream colnum colinc))))) (defun output-spaces (stream n) (let ((spaces #.(make-string 100 :initial-element #\space))) (loop (when (< n (length spaces)) (return)) (write-string spaces stream) (decf n (length spaces))) (write-string spaces stream :end n))) ;; CLHS 22.3.6.1 for relative tabulations says: ;; ;; ... outputs COLREL spaces and then outputs the smallest ;; non-negative number of additional spaces necessary to move the ;; cursor to a column that is a multiple of COLINC.... If the ;; current output column cannot be determined, however, then colinc ;; is ignored, and exactly colrel spaces are output. (defun format-relative-tab (stream colrel colinc) (if (pp:pretty-stream-p stream) (pprint-tab :line-relative colrel colinc stream) (flet ((advance-to-column () (let* ((cur (lisp::charpos stream)) (spaces (if (and cur (plusp colinc)) (- (* (ceiling (+ cur colrel) colinc) colinc) cur) colrel))) (output-spaces stream spaces)))) (lisp::stream-dispatch stream ;; simple-stream (advance-to-column) ;; lisp-stream (advance-to-column) ;; fundamental-stream (let ((cur (stream-line-column stream))) (cond ((and cur (plusp colinc)) (stream-advance-to-column stream (+ cur (* (floor (+ cur colrel) colinc) colinc)))) (t (stream-advance-to-column stream (+ cur colrel))))))))) ;; CLHS 22.3.6.1 says: ;; ;; If the cursor is already at or beyond the column COLNUM, it will ;; output spaces to move it to COLNUM + k*COLINC for the smallest ;; positive integer k possible, unless COLINC is zero, in which case ;; no spaces are output. (defun format-absolute-tab (stream colnum colinc) (if (pp:pretty-stream-p stream) (pprint-tab :line colnum colinc stream) (flet ((advance-to-column () (let ((cur (lisp::charpos stream))) (cond ((null cur) (write-string " " stream)) ((< cur colnum) (output-spaces stream (- colnum cur))) (t (unless (zerop colinc) (output-spaces stream (- colinc (rem (- cur colnum) colinc))))))))) (lisp::stream-dispatch stream ;; simple-stream. NOTE: Do we need to do soemthing better for ;; simple streams? (advance-to-column) ;; lisp-stream (advance-to-column) ;; fundamental-stream (let ((cur (stream-line-column stream))) (cond ((null cur) (write-string " " stream)) ((< cur colnum) (stream-advance-to-column stream colnum)) (t (unless (zerop colinc) (let ((k (ceiling (- cur colnum) colinc))) (stream-advance-to-column stream (+ colnum (* k colinc)))))))))))) (def-format-directive #\_ (colonp atsignp params) (expand-bind-defaults () params `(pprint-newline ,(if colonp (if atsignp :mandatory :fill) (if atsignp :miser :linear)) stream))) (def-format-interpreter #\_ (colonp atsignp params) (interpret-bind-defaults () params (pprint-newline (if colonp (if atsignp :mandatory :fill) (if atsignp :miser :linear)) stream))) (def-format-directive #\I (colonp atsignp params) (when atsignp (error 'format-error :complaint (intl:gettext "Cannot specify the at-sign modifier."))) (expand-bind-defaults ((n 0)) params `(pprint-indent ,(if colonp :current :block) ,n stream))) (def-format-interpreter #\I (colonp atsignp params) (when atsignp (error 'format-error :complaint (intl:gettext "Cannot specify the at-sign modifier."))) (interpret-bind-defaults ((n 0)) params (pprint-indent (if colonp :current :block) n stream))) ;;;; * (def-format-directive #\* (colonp atsignp params end) (if atsignp (if colonp (error 'format-error :complaint (intl:gettext "Cannot specify both colon and at-sign.")) (expand-bind-defaults ((posn 0)) params (unless *orig-args-available* (throw 'need-orig-args nil)) `(if (<= 0 ,posn (length orig-args)) (setf args (nthcdr ,posn orig-args)) (error 'format-error :complaint (intl:gettext "Index ~D out of bounds. Should have been ~ between 0 and ~D.") :arguments (list ,posn (length orig-args)) :offset ,(1- end))))) (if colonp (expand-bind-defaults ((n 1)) params (unless *orig-args-available* (throw 'need-orig-args nil)) `(do ((cur-posn 0 (1+ cur-posn)) (arg-ptr orig-args (cdr arg-ptr))) ((eq arg-ptr args) (let ((new-posn (- cur-posn ,n))) (if (<= 0 new-posn (length orig-args)) (setf args (nthcdr new-posn orig-args)) (error 'format-error :complaint (intl:gettext "Index ~D out of bounds. Should have been ~ between 0 and ~D.") :arguments (list new-posn (length orig-args)) :offset ,(1- end))))))) (if params (expand-bind-defaults ((n 1)) params (setf *only-simple-args* nil) `(dotimes (i ,n) ,(expand-next-arg))) (expand-next-arg))))) (def-format-interpreter #\* (colonp atsignp params) (if atsignp (if colonp (error 'format-error :complaint (intl:gettext "Cannot specify both colon and at-sign.")) (interpret-bind-defaults ((posn 0)) params (if (<= 0 posn (length orig-args)) (setf args (nthcdr posn orig-args)) (error 'format-error :complaint (intl:gettext "Index ~D out of bounds. Should have been ~ between 0 and ~D.") :arguments (list posn (length orig-args)))))) (if colonp (interpret-bind-defaults ((n 1)) params (do ((cur-posn 0 (1+ cur-posn)) (arg-ptr orig-args (cdr arg-ptr))) ((eq arg-ptr args) (let ((new-posn (- cur-posn n))) (if (<= 0 new-posn (length orig-args)) (setf args (nthcdr new-posn orig-args)) (error 'format-error :complaint (intl:gettext "Index ~D out of bounds. Should have been ~ between 0 and ~D.") :arguments (list new-posn (length orig-args)))))))) (interpret-bind-defaults ((n 1)) params (dotimes (i n) (next-arg)))))) ;;;; Indirection. (def-format-directive #\? (colonp atsignp params string end) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier."))) (expand-bind-defaults () params `(handler-bind ((format-error #'(lambda (condition) (error 'format-error :complaint (intl:gettext "~A~%while processing indirect format string:") :arguments (list condition) :print-banner nil :control-string ,string :offset ,(1- end))))) ,(if atsignp (if *orig-args-available* `(setf args (%format stream ,(expand-next-arg) orig-args args)) (throw 'need-orig-args nil)) `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) (def-format-interpreter #\? (colonp atsignp params string end) (when colonp (error 'format-error :complaint (intl:gettext "Cannot specify the colon modifier."))) (interpret-bind-defaults () params (handler-bind ((format-error #'(lambda (condition) (error 'format-error :complaint (intl:gettext "~A~%while processing indirect format string:") :arguments (list condition) :print-banner nil :control-string string :offset (1- end))))) (if atsignp (setf args (%format stream (next-arg) orig-args args)) (%format stream (next-arg) (next-arg)))))) ;;;; Capitalization. (def-complex-format-directive #\( (colonp atsignp params directives) (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error :complaint (intl:gettext "No corresponding close paren."))) (let* ((posn (position close directives)) (before (subseq directives 0 posn)) (after (nthcdr (1+ posn) directives))) (values (expand-bind-defaults () params `(let ((stream (make-case-frob-stream stream ,(if colonp (if atsignp :upcase :capitalize) (if atsignp :capitalize-first :downcase))))) ,@(expand-directive-list before))) after)))) (def-complex-format-interpreter #\( (colonp atsignp params directives) (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error :complaint (intl:gettext "No corresponding close paren."))) (interpret-bind-defaults () params (let* ((posn (position close directives)) (before (subseq directives 0 posn)) (after (nthcdr (1+ posn) directives)) (stream (make-case-frob-stream stream (if colonp (if atsignp :upcase :capitalize) (if atsignp :capitalize-first :downcase))))) (setf args (interpret-directive-list stream before orig-args args)) after)))) (def-complex-format-directive #\) () (error 'format-error :complaint (intl:gettext "No corresponding open paren."))) (def-complex-format-interpreter #\) () (error 'format-error :complaint (intl:gettext "No corresponding open paren."))) ;;;; Conditionals (defun parse-conditional-directive (directives) (let ((sublists nil) (last-semi-with-colon-p nil) (remaining directives)) (loop (let ((close-or-semi (find-directive remaining #\] t))) (unless close-or-semi (error 'format-error :complaint (intl:gettext "No corresponding close bracket."))) (let ((posn (position close-or-semi remaining))) (push (subseq remaining 0 posn) sublists) (setf remaining (nthcdr (1+ posn) remaining)) (when (char= (format-directive-character close-or-semi) #\]) (return)) (setf last-semi-with-colon-p (format-directive-colonp close-or-semi))))) (values sublists last-semi-with-colon-p remaining))) (def-complex-format-directive #\[ (colonp atsignp params directives) (multiple-value-bind (sublists last-semi-with-colon-p remaining) (parse-conditional-directive directives) (values (if atsignp (if colonp (error 'format-error :complaint (intl:gettext "Cannot specify both the colon and at-sign modifiers.")) (if (cdr sublists) (error 'format-error :complaint (intl:gettext "Can only specify one section")) (expand-bind-defaults () params (expand-maybe-conditional (car sublists))))) (if colonp (if (= (length sublists) 2) (progn (when last-semi-with-colon-p (error 'format-error :complaint (intl:gettext "~~:; directive not effective in ~~:["))) (expand-bind-defaults () params (expand-true-false-conditional (car sublists) (cadr sublists)))) (error 'format-error :complaint (intl:gettext "Must specify exactly two sections."))) (expand-bind-defaults ((index nil)) params (setf *only-simple-args* nil) (let ((clauses nil) (case `(or ,index ,(expand-next-arg)))) (when last-semi-with-colon-p (push `(t ,@(expand-directive-list (pop sublists))) clauses)) (let ((count (length sublists))) (dolist (sublist sublists) (push `(,(decf count) ,@(expand-directive-list sublist)) clauses))) `(case ,case ,@clauses))))) remaining))) (defun expand-maybe-conditional (sublist) (flet ((hairy () `(let ((prev-args args) (arg ,(expand-next-arg))) (when arg (setf args prev-args) ,@(expand-directive-list sublist))))) (if *only-simple-args* (multiple-value-bind (guts new-args) (let ((*simple-args* *simple-args*)) (values (expand-directive-list sublist) *simple-args*)) (cond ((and new-args (eq *simple-args* (cdr new-args))) (setf *simple-args* new-args) `(when ,(caar new-args) ,@guts)) (t (setf *only-simple-args* nil) (hairy)))) (hairy)))) (defun expand-true-false-conditional (true false) (let ((arg (expand-next-arg))) (flet ((hairy () `(if ,arg (progn ,@(expand-directive-list true)) (progn ,@(expand-directive-list false))))) (if *only-simple-args* (multiple-value-bind (true-guts true-args true-simple) (let ((*simple-args* *simple-args*) (*only-simple-args* t)) (values (expand-directive-list true) *simple-args* *only-simple-args*)) (multiple-value-bind (false-guts false-args false-simple) (let ((*simple-args* *simple-args*) (*only-simple-args* t)) (values (expand-directive-list false) *simple-args* *only-simple-args*)) (if (= (length true-args) (length false-args)) `(if ,arg (progn ,@true-guts) ,(do ((false false-args (cdr false)) (true true-args (cdr true)) (bindings nil (cons `(,(caar false) ,(caar true)) bindings))) ((eq true *simple-args*) (setf *simple-args* true-args) (setf *only-simple-args* (and true-simple false-simple)) (if bindings `(let ,bindings ,@false-guts) `(progn ,@false-guts))))) (progn (setf *only-simple-args* nil) (hairy))))) (hairy))))) (def-complex-format-interpreter #\[ (colonp atsignp params directives) (multiple-value-bind (sublists last-semi-with-colon-p remaining) (parse-conditional-directive directives) (setf args (if atsignp (if colonp (error 'format-error :complaint (intl:gettext "Cannot specify both the colon and at-sign modifiers.")) (if (cdr sublists) (error 'format-error :complaint (intl:gettext "Can only specify one section")) (interpret-bind-defaults () params (let ((prev-args args) (arg (next-arg))) (if arg (interpret-directive-list stream (car sublists) orig-args prev-args) args))))) (if colonp (if (= (length sublists) 2) (interpret-bind-defaults () params (if (next-arg) (interpret-directive-list stream (car sublists) orig-args args) (interpret-directive-list stream (cadr sublists) orig-args args))) (error 'format-error :complaint (intl:gettext "Must specify exactly two sections."))) (interpret-bind-defaults ((index (next-arg))) params (let* ((default (and last-semi-with-colon-p (pop sublists))) (last (1- (length sublists))) (sublist (if (<= 0 index last) (nth (- last index) sublists) default))) (interpret-directive-list stream sublist orig-args args)))))) remaining)) (def-complex-format-directive #\; () (error 'format-error :complaint (intl:gettext "~~; not contained within either ~~[...~~] or ~~<...~~>."))) (def-complex-format-interpreter #\; () (error 'format-error :complaint (intl:gettext "~~; not contained within either ~~[...~~] or ~~<...~~>."))) (def-complex-format-interpreter #\] () (error 'format-error :complaint (intl:gettext "No corresponding open bracket."))) (def-complex-format-directive #\] () (error 'format-error :complaint (intl:gettext "No corresponding open bracket."))) ;;;; Up-and-out. (defvar *outside-args*) (def-format-directive #\^ (colonp atsignp params) (when atsignp (error 'format-error :complaint (intl:gettext "Cannot specify the at-sign modifier."))) (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :complaint (intl:gettext "Attempt to use ~~:^ outside a ~~:{...~~} construct."))) ;; See the #\^ interpreter below for what happens here. `(when ,(case (length params) (0 (if colonp '(null outside-args) (progn (setf *only-simple-args* nil) '(null args)))) (1 (expand-bind-defaults ((count nil)) params `(if ,count (eql ,count 0) ,(if colonp '(null outside-args) (progn (setf *only-simple-args* nil) '(null args)))))) (2 (expand-bind-defaults ((arg1 nil) (arg2 nil)) params `(if ,arg2 (eql ,arg1 ,arg2) (eql ,arg1 0)))) (t (expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params `(if ,arg3 (<= ,arg1 ,arg2 ,arg3) (if ,arg2 (eql ,arg1 ,arg2) ;; Duplicate the case of 1 arg? (eql ,arg1 0)))))) ,(if colonp '(return-from outside-loop nil) '(return)))) (def-format-interpreter #\^ (colonp atsignp params) (when atsignp (error 'format-error :complaint (intl:gettext "Cannot specify the at-sign modifier."))) (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :complaint (intl:gettext "Attempt to use ~~:^ outside a ~~:{...~~} construct."))) ;; This is messy because, as I understand it, and as tested by ;; ansi-tests, a NIL parameter is the same as not given. Thus for 2 ;; args, if the second is nil, we have to pretend that only 1 was ;; given. Similarly for 3 args. ;; ;; Also, ansi-tests interprets CLHS 22.3.9.2 such that "equal" ;; parameter means equal (or at least eql). ;; ;; FIXME: This needs to be done in a better way! (when (case (length params) (0 (if colonp (null *outside-args*) (null args))) (1 (interpret-bind-defaults ((count nil)) params (if count (eql count 0) (if colonp (null *outside-args*) (null args))))) (2 (interpret-bind-defaults ((arg1 nil) (arg2 nil)) params (if arg2 (eql arg1 arg2) ;; Should we duplicate the previous case here? (eql arg1 0)))) (t (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params (if arg3 (<= arg1 arg2 arg3) (if arg2 (eql arg1 arg2) ;; Duplicate the case of 1 arg? (eql arg1 0)))))) (throw (if colonp 'up-up-and-out 'up-and-out) args))) ;;;; Iteration. (def-complex-format-directive #\{ (colonp atsignp params string end directives) (let ((close (find-directive directives #\} nil))) (unless close (error 'format-error :complaint (intl:gettext "No corresponding close brace."))) (let* ((closed-with-colon (format-directive-colonp close)) (posn (position close directives))) (labels ((compute-insides () (if (zerop posn) (if *orig-args-available* `((handler-bind ((format-error #'(lambda (condition) (error 'format-error :complaint (intl:gettext "~A~%while processing indirect format string:") :arguments (list condition) :print-banner nil :control-string ,string :offset ,(1- end))))) (setf args (%format stream inside-string orig-args args)))) (throw 'need-orig-args nil)) (let ((*up-up-and-out-allowed* colonp)) (expand-directive-list (subseq directives 0 posn))))) (compute-loop (count) (when atsignp (setf *only-simple-args* nil)) `(loop ,@(unless closed-with-colon '((when (null args) (return)))) ,@(when count `((when (and ,count (minusp (decf ,count))) (return)))) ,@(if colonp (let ((*expander-next-arg-macro* 'expander-next-arg) (*only-simple-args* nil) (*orig-args-available* t)) `((let* ((orig-args ,(expand-next-arg)) (outside-args args) (args orig-args)) (declare (ignorable orig-args outside-args args)) (block nil ,@(compute-insides))))) (compute-insides)) ,@(when closed-with-colon '((when (null args) (return)))))) (compute-block (count) (if colonp `(block outside-loop ,(compute-loop count)) (compute-loop count))) (compute-bindings (count) (if atsignp (compute-block count) `(let* ((orig-args ,(expand-next-arg)) (args orig-args)) (declare (ignorable orig-args args)) ,(let ((*expander-next-arg-macro* 'expander-next-arg) (*only-simple-args* nil) (*orig-args-available* t)) (compute-block count)))))) (values (if params (expand-bind-defaults ((count nil)) params (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings count)) (compute-bindings count))) (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings nil)) (compute-bindings nil))) (nthcdr (1+ posn) directives)))))) (def-complex-format-interpreter #\{ (colonp atsignp params string end directives) (let ((close (find-directive directives #\} nil))) (unless close (error 'format-error :complaint (intl:gettext "No corresponding close brace."))) (interpret-bind-defaults ((max-count nil)) params (let* ((closed-with-colon (format-directive-colonp close)) (posn (position close directives)) (insides (if (zerop posn) (next-arg) (subseq directives 0 posn))) (*up-up-and-out-allowed* colonp)) (labels ((do-guts (orig-args args) (if (zerop posn) (handler-bind ((format-error #'(lambda (condition) (error 'format-error :complaint (intl:gettext "~A~%while processing indirect format string:") :arguments (list condition) :print-banner nil :control-string string :offset (1- end))))) (%format stream insides orig-args args)) (interpret-directive-list stream insides orig-args args))) (bind-args (orig-args args) (if colonp (let* ((arg (next-arg)) (*logical-block-popper* nil) (*outside-args* args)) (catch 'up-and-out (do-guts arg arg)) args) (do-guts orig-args args))) (do-loop (orig-args args) (catch (if colonp 'up-up-and-out 'up-and-out) (loop (when (and (not closed-with-colon) (null args)) (return)) (when (and max-count (minusp (decf max-count))) (return)) (setf args (bind-args orig-args args)) (when (and closed-with-colon (null args)) (return))) args))) (if atsignp (setf args (do-loop orig-args args)) (let ((arg (next-arg)) (*logical-block-popper* nil)) (do-loop arg arg))) (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () (error 'format-error :complaint (intl:gettext "No corresponding open brace."))) (def-complex-format-interpreter #\} () (error 'format-error :complaint (intl:gettext "No corresponding open brace."))) ;;;; Justification. (defparameter *illegal-inside-justification* (mapcar (lambda (x) (parse-directive x 0)) '("~W" "~:W" "~@W" "~:@W" "~_" "~:_" "~@_" "~:@_" "~:>" "~:@>" "~I" "~:I" "~@I" "~:@I" "~:T" "~:@T"))) (defun illegal-inside-justification-p (directive) (member directive *illegal-inside-justification* :test (lambda (x y) (and (format-directive-p x) (format-directive-p y) (eql (format-directive-character x) (format-directive-character y)) (eql (format-directive-colonp x) (format-directive-colonp y)) (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) (def-complex-format-directive #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (values (if (format-directive-colonp close) (multiple-value-bind (prefix per-line-p insides suffix) (parse-format-logical-block segments colonp first-semi close params string end) (expand-format-logical-block prefix per-line-p insides suffix atsignp)) (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) (when (> count 0) ;; ANSI specifies that "an error is signalled" in this ;; situation. (error 'format-error :complaint (intl:ngettext "~D illegal directive found inside justification block" "~D illegal directives found inside justification block" count) :arguments (list count))) (expand-format-justification segments colonp atsignp first-semi params))) remaining))) (def-complex-format-interpreter #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (setf args (if (format-directive-colonp close) (multiple-value-bind (prefix per-line-p insides suffix) (parse-format-logical-block segments colonp first-semi close params string end) (interpret-format-logical-block stream orig-args args prefix per-line-p insides suffix atsignp)) (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) (when (> count 0) ;; ANSI specifies that "an error is signalled" in this ;; situation. (error 'format-error :complaint (intl:ngettext "~D illegal directive found inside justification block" "~D illegal directives found inside justification block" count) :arguments (list count))) (interpret-format-justification stream orig-args args segments colonp atsignp first-semi params)))) remaining)) (defun parse-format-justification (directives) (let ((first-semi nil) (close nil) (remaining directives)) (collect ((segments)) (loop (let ((close-or-semi (find-directive remaining #\> t))) (unless close-or-semi (error 'format-error :complaint (intl:gettext "No corresponding close bracket."))) (let ((posn (position close-or-semi remaining))) (segments (subseq remaining 0 posn)) (setf remaining (nthcdr (1+ posn) remaining))) (when (char= (format-directive-character close-or-semi) #\>) (setf close close-or-semi) (return)) (unless first-semi (setf first-semi close-or-semi)))) (values (segments) first-semi close remaining)))) (defun expand-format-justification (segments colonp atsignp first-semi params) (let ((newline-segment-p (and first-semi (format-directive-colonp first-semi)))) (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params `(let ((segments nil) ,@(when newline-segment-p '((newline-segment nil) (extra-space 0) (line-len 72)))) (block nil ,@(when newline-segment-p `((setf newline-segment (with-output-to-string (stream) ,@(expand-directive-list (pop segments)))) ,(expand-bind-defaults ((extra 0) (line-len '(or (lisp::line-length stream) 72))) (format-directive-params first-semi) `(setf extra-space ,extra line-len ,line-len)))) ,@(mapcar #'(lambda (segment) `(push (with-output-to-string (stream) ,@(expand-directive-list segment)) segments)) segments)) (format-justification stream ,@(if newline-segment-p '(newline-segment extra-space line-len) '(nil 0 0)) segments ,colonp ,atsignp ,mincol ,colinc ,minpad ,padchar))))) (defun interpret-format-justification (stream orig-args args segments colonp atsignp first-semi params) (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params (let ((newline-string nil) (strings nil) (extra-space 0) (line-len 0)) (setf args (catch 'up-and-out (when (and first-semi (format-directive-colonp first-semi)) (interpret-bind-defaults ((extra 0) (len (or (lisp::line-length stream) 72))) (format-directive-params first-semi) (setf newline-string (with-output-to-string (stream) (setf args (interpret-directive-list stream (pop segments) orig-args args)))) (setf extra-space extra) (setf line-len len))) (dolist (segment segments) (push (with-output-to-string (stream) (setf args (interpret-directive-list stream segment orig-args args))) strings)) args)) (format-justification stream newline-string extra-space line-len strings colonp atsignp mincol colinc minpad padchar))) args) (defun format-justification (stream newline-prefix extra-space line-len strings pad-left pad-right mincol colinc minpad padchar) (setf strings (reverse strings)) (let* ((num-gaps (+ (1- (length strings)) (if pad-left 1 0) (if pad-right 1 0))) (chars (+ (* num-gaps minpad) (loop for string in strings summing (length string)))) (length (if (> chars mincol) (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) mincol)) (padding (+ (- length chars) (* num-gaps minpad)))) (when (and newline-prefix (> (+ (or (lisp::charpos stream) 0) length extra-space) line-len)) (write-string newline-prefix stream)) #|| (format t "mincol = ~A~%" mincol) (format t "minpad = ~A~%" minpad) (format t "num-gaps = ~A~%" num-gaps) (format t "chars = ~A~%" chars) (format t "length = ~A~%" length) (format t "padding = ~A~%" padding) ||# (flet ((do-padding () (let ((pad-len (if (zerop num-gaps) padding (truncate padding num-gaps)))) (decf padding pad-len) (decf num-gaps) (dotimes (i pad-len) (write-char padchar stream))))) (when (or pad-left (and (not pad-right) (null (cdr strings)))) (do-padding)) (when strings (write-string (car strings) stream) (dolist (string (cdr strings)) (do-padding) (write-string string stream))) (when pad-right (do-padding))))) (defun parse-format-logical-block (segments colonp first-semi close params string end) (when params (error 'format-error :complaint (intl:gettext "No parameters can be supplied with ~~<...~~:>.") :offset (caar params))) (multiple-value-bind (prefix insides suffix) (multiple-value-bind (prefix-default suffix-default) (if colonp (values "(" ")") (values "" "")) (flet ((extract-string (list prefix-p) (let ((directive (find-if #'format-directive-p list))) (if directive (error 'format-error :complaint (intl:gettext "Cannot include format directives inside the ~ ~:[suffix~;prefix~] segment of ~~<...~~:>") :arguments (list prefix-p) :offset (1- (format-directive-end directive))) (apply #'concatenate 'string list))))) (case (length segments) (0 (values prefix-default nil suffix-default)) (1 (values prefix-default (car segments) suffix-default)) (2 (values (extract-string (car segments) t) (cadr segments) suffix-default)) (3 (values (extract-string (car segments) t) (cadr segments) (extract-string (caddr segments) nil))) (t (error 'format-error :complaint (intl:gettext "Too many segments for ~~<...~~:>.")))))) (when (format-directive-atsignp close) (setf insides (add-fill-style-newlines insides string (if first-semi (format-directive-end first-semi) end)))) (values prefix (and first-semi (format-directive-atsignp first-semi)) insides suffix))) ;; CLHS 22.3.5.2 says fill-style conditional newlines are ;; automatically inserted after each group of blanks except for blanks ;; after a newline directive. (defun add-fill-style-newlines (list string offset &optional newlinep) (if list (let ((directive (car list))) (if (simple-string-p directive) (nconc (add-fill-style-newlines-aux directive string offset newlinep) (add-fill-style-newlines (cdr list) string (+ offset (length directive)))) (cons directive (add-fill-style-newlines (cdr list) string (format-directive-end directive) (char= (format-directive-character directive) #\Newline))))) nil)) (defun add-fill-style-newlines-aux (literal string offset &optional newlinep) (let ((end (length literal)) (posn 0)) (collect ((results)) (loop (let ((blank (position #\space literal :start posn))) (when (null blank) (results (subseq literal posn)) (return)) (let ((non-blank (or (position #\space literal :start blank :test #'char/=) end))) (results (subseq literal posn non-blank)) (unless newlinep (results (make-format-directive :string string :character #\_ :start (+ offset non-blank) :end (+ offset non-blank) :colonp t :atsignp nil :params nil))) (setf posn non-blank)) (when (= posn end) (return)))) (results)))) (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) `(let ((arg ,(if atsignp 'args (expand-next-arg)))) ,@(when atsignp (setf *only-simple-args* nil) '((setf args nil))) (pprint-logical-block (stream arg ,(if per-line-p :per-line-prefix :prefix) (or ,prefix "") :suffix (or ,suffix "")) (let ((args arg) ,@(unless atsignp `((orig-args arg)))) (declare (ignorable args ,@(unless atsignp '(orig-args)))) (block nil ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) (*only-simple-args* nil) (*orig-args-available* t)) (expand-directive-list insides))))))) (defun interpret-format-logical-block (stream orig-args args prefix per-line-p insides suffix atsignp) (let ((arg (if atsignp args (next-arg)))) (if per-line-p (pprint-logical-block (stream arg :per-line-prefix prefix :suffix suffix) (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) (catch 'up-and-out (interpret-directive-list stream insides (if atsignp orig-args arg) arg)))) (pprint-logical-block (stream arg :prefix prefix :suffix suffix) (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) (catch 'up-and-out (interpret-directive-list stream insides (if atsignp orig-args arg) arg)))))) (if atsignp nil args)) (def-complex-format-directive #\> () (error 'format-error :complaint (intl:gettext "No corresponding open bracket."))) ;;;; User-defined method. (def-format-directive #\/ (string start end colonp atsignp params) (let ((symbol (extract-user-function-name string start end))) (collect ((param-names) (bindings)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset))) (let ((param-name (gensym))) (param-names param-name) (bindings `(,param-name ,(case param (:arg (expand-next-arg)) (:remaining '(length args)) (t param))))))) `(let ,(bindings) (,symbol stream ,(expand-next-arg) ,colonp ,atsignp ,@(param-names)))))) (def-format-interpreter #\/ (string start end colonp atsignp params) (let ((symbol (extract-user-function-name string start end))) (collect ((args)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset))) (case param (:arg (args (next-arg))) (:remaining (args (length args))) (t (args param))))) (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) (defun extract-user-function-name (string start end) (let ((slash (position #\/ string :start start :end (1- end) :from-end t))) (unless slash (error 'format-error :complaint (intl:gettext "Malformed ~~/ directive."))) (let* ((name (string-upcase (let ((foo string)) ;; Hack alert: This is to keep the compiler ;; quiet about deleting code inside the ;; subseq expansion. (subseq foo (1+ slash) (1- end))))) (first-colon (position #\: name)) (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) (package-name (if first-colon (subseq name 0 first-colon) "COMMON-LISP-USER")) (package (find-package package-name))) (unless package (error 'format-error :complaint (intl:gettext "No package named ~S") :arguments (list package-name))) (intern (cond ((and second-colon (= second-colon (1+ first-colon))) (subseq name (1+ second-colon))) (first-colon (subseq name (1+ first-colon))) (t name)) package)))) ;;;; Compile-time checking of format arguments and control string ;;; ;;; Return the min/max numbers of arguments required for a call to ;;; FORMAT with control string FORMAT-STRING, null if we can't tell, ;;; or a string with an error message if parsing the control string ;;; causes a FORMAT-ERROR. ;;; ;;; This is called from FORMAT deftransforms. ;;; (defun min/max-format-arguments-count (string) (handler-case (catch 'give-up ;; For the side effect of validating the control string. (%formatter string) (%min/max-format-args (tokenize-control-string string))) (format-error (e) (format nil "~a" e)))) (defun %min/max-format-args (directives) (let ((min-req 0) (max-req 0)) (flet ((incf-both (&optional (n 1)) (incf min-req n) (incf max-req n))) (loop (let ((dir (pop directives))) (when (null dir) (return (values min-req max-req))) (when (format-directive-p dir) (incf-both (count :arg (format-directive-params dir) :key #'cdr)) (let ((c (format-directive-character dir)) close) (cond ((find c "ABCDEFGORSWX$/") (incf-both)) ((char= c #\P) (unless (format-directive-colonp dir) (incf-both))) ((and (char= c #\<) (not (format-directive-atsignp dir)) (setq close (find-directive directives #\> nil)) (format-directive-colonp close)) (incf-both) (setq directives (cdr (member close directives)))) ((or (find c "IT%&|_<>();") (char= c #\newline) (char= c #\~))) ((char= c #\[) (multiple-value-bind (min max remaining) (%min/max-conditional-args dir directives) (setq directives remaining) (incf min-req min) (incf max-req max))) ((char= c #\{) (multiple-value-bind (min max remaining) (%min/max-iteration-args dir directives) (setq directives remaining) (incf min-req min) (incf max-req max))) ((char= c #\?) (cond ((format-directive-atsignp dir) (incf min-req) (setq max-req most-positive-fixnum)) (t (incf-both 2)))) (t (throw 'give-up nil)))))))))) ;;; ;;; ANSI: if arg is out of range, no clause is selected. That means ;;; the minimum number of args required for the interior of ~[~] is ;;; always zero. ;;; (defun %min/max-conditional-args (conditional directives) (multiple-value-bind (sublists last-semi-with-colon-p remaining) (parse-conditional-directive directives) (declare (ignore last-semi-with-colon-p)) (let ((sub-max (loop for s in sublists maximize (nth-value 1 (%min/max-format-args s)))) (min-req 1) max-req) (cond ((format-directive-atsignp conditional) (setq max-req (max 1 sub-max))) ((loop for p in (format-directive-params conditional) thereis (or (integerp (cdr p)) (memq (cdr p) '(:remaining :arg)))) (setq min-req 0) (setq max-req sub-max)) (t (setq max-req (1+ sub-max)))) (values min-req max-req remaining)))) (defun %min/max-iteration-args (iteration directives) (let* ((close (find-directive directives #\} nil)) (posn (position close directives)) (remaining (nthcdr (1+ posn) directives))) (if (format-directive-atsignp iteration) (values (if (zerop posn) 1 0) most-positive-fixnum remaining) (let ((nreq (if (zerop posn) 2 1))) (values nreq nreq remaining))))) cmucl-21a/src/code/fwrappers.lisp000066400000000000000000000253601260377556400171720ustar00rootroot00000000000000;;; Copyright (C) 2003 Gerd Moellmann ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. 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. ;;; 3. The name of the author may not be used to endorse or promote ;;; products derived from this software without specific prior written ;;; permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS ;;; 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 OR CONTRIBUTORS 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. (ext:file-comment "$Header: src/code/fwrappers.lisp $") (in-package :fwrappers) (intl:textdomain "cmucl") (defstruct (fwrapper (:alternate-metaclass kernel:funcallable-instance kernel:funcallable-structure-class kernel:make-funcallable-structure-class) (:type kernel:funcallable-structure) (:constructor make-fwrapper (constructor type user-data)) (:print-function print-fwrapper)) _N"A funcallable instance used to implement fwrappers. The CONSTRUCTOR slot is a function defined with DEFINE-FWRAPPER. This function returns an instance closure closing over an fwrapper object, which is installed as the funcallable-instance function of the fwrapper object." (next #'null :type function) (type nil :type t) (constructor #'null :type function) (user-data nil :type t)) (defun print-fwrapper (fwrapper stream depth) "Print-function for struct FWRAPPER." (declare (ignore depth)) (print-unreadable-object (fwrapper stream :type t :identity t) (format stream "~s" (fwrapper-type fwrapper)))) (declaim (inline fwrapper-or-nil)) (defun fwrapper-or-nil (fun) "Return FUN if it is an fwrapper or nil if it isn't." (and (functionp fun) ;; Necessary for cold-load reasons. (= (get-type fun) vm:funcallable-instance-header-type) (fwrapper-p fun) fun)) (defmacro do-fwrappers ((var fdefn &optional result) &body body) "Evaluate BODY with VAR bound to consecutive fwrappers of FDEFN. Return RESULT at the end." `(loop for ,var = (fwrapper-or-nil (fdefn-function ,fdefn)) then (fwrapper-or-nil (fwrapper-next ,var)) while ,var do (locally ,@body) finally (return ,result))) (declaim (inline last-fwrapper)) (defun last-fwrapper (fdefn) "Return tha last encapsulation of FDEFN or NIL if none." (do-fwrappers (f fdefn) (when (null (fwrapper-or-nil (fwrapper-next f))) (return f)))) (defun push-fwrapper (f function-name) "Prepend encapsulation F to the definition of FUNCTION-NAME. Signal an error if FUNCTION-NAME is an undefined function." (declare (type fwrapper f)) (let ((fdefn (fdefn-or-lose function-name))) (setf (fwrapper-next f) (fdefn-function fdefn)) (setf (fdefn-function fdefn) f))) (defun delete-fwrapper (f function-name) "Remove fwrapper F from the definition of FUNCTION-NAME." (set-fwrappers function-name (delete f (list-fwrappers function-name)))) (defun list-fwrappers (function-name) "Return a list of all fwrappers of FUNCTION-NAME, ordered from outermost to innermost." (collect ((result)) (do-fwrappers (f (fdefn-or-lose function-name) (result)) (result f)))) (defun set-fwrappers (function-name fwrappers) "Set FUNCTION-NAMES's fwrappers to elements of the list FWRAPPERS, which is assumed to be ordered from outermost to innermost. FWRAPPERS null means remove all fwrappers." (let ((fdefn (fdefn-or-lose function-name)) (primary-function (fdefinition function-name))) (setf (fdefn-function fdefn) primary-function) (dolist (f (reverse fwrappers)) (push-fwrapper f function-name)))) (defun fwrap (function-name constructor &key type user-data) "Wrap the function named FUNCTION-NAME in an fwrapper of type TYPE, created by calling CONSTRUCTOR. CONSTRUCTOR is a function defined with DEFINE-FWRAPPER, or the name of such a function. Return the fwrapper created. USER-DATA is arbitrary data to be associated with the fwrapper. It is accessible in wrapper functions defined with DEFINE-FWRAPPER as (FWRAPPER-USER-DATA FWRAPPER)." (let ((f (make-fwrapper (coerce constructor 'function) type user-data))) (update-fwrapper f) (push-fwrapper f function-name))) (defun funwrap (function-name &key (type nil type-p) test) "Remove fwrappers from the function named FUNCTION-NAME. If TYPE is supplied, remove fwrappers whose type is equal to TYPE. If TEST is supplied, remove fwrappers satisfying TEST. If both are not specified, remove all fwrappers." (collect ((new)) (when (or type-p test) (do-fwrappers (f (fdefn-or-lose function-name)) (when (or (not type-p) (not (equal type (fwrapper-type f)))) (when (or (null test) (not (funcall test f))) (new f)))) (set-fwrappers function-name (new))))) (defun update-fwrapper (f) "Update the funcallable instance function of fwrapper F from its constructor." (setf (kernel:funcallable-instance-function f) (funcall (fwrapper-constructor f) f))) (defun update-fwrappers (function-name &key (type nil type-p) test) "Update fwrapper function definitions of FUNCTION-NAME. If TYPE is supplied, update fwrappers whose type is equal to TYPE. If TEST is supplied, update fwrappers satisfying TEST." (do-fwrappers (f (fdefn-or-lose function-name)) (when (or (not type-p) (not (equal type (fwrapper-type f)))) (when (or (null test) (not (funcall test f))) (update-fwrapper f))))) (defun find-fwrapper (function-name &key (type nil type-p) test) "Find an fwrapper of FUNCTION-NAME. If TYPE is supplied, find an fwrapper whose type is equal to TYPE. If TEST is supplied, find an fwrapper satisfying TEST." (do-fwrappers (f (fdefn-or-lose function-name)) (when (or (not type-p) (equal type (fwrapper-type f))) (when (or (null test) (funcall test f)) (return f))))) (defmacro define-fwrapper (name lambda-list &body body &environment env) "Like DEFUN, but define a function wrapper. In BODY, the symbol FWRAPPERS:FWRAPPERS refers to the currently executing fwrapper. FWRAPPERS:CALL-NEXT-FUNCTION can be used in BODY to call the next fwrapper or the primary function. When called with no arguments, CALL-NEXT-FUNCTION invokes the next function with the original args to the fwrapper, otherwise it invokes the next function with the supplied args." (expand-define-fwrapper name lambda-list body env)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun expand-define-fwrapper (name lambda-list body env) "Return the expansion of a DEFINE-FWRAPPER." (multiple-value-bind (required optional restp rest keyp keys allowp aux morep) (kernel:parse-lambda-list lambda-list) (when morep (error (intl:gettext "&MORE not supported in fwrapper lambda lists"))) (multiple-value-bind (body declarations documentation) (system:parse-body body env t) (multiple-value-bind (lambda-list call-next) (flet ((make-call-next (restp) `(multiple-value-call (fwrapper-next fwrapper) (values ,@required) ,(if restp `(values-list ,rest) `(c:%more-arg-values .c. 0 .n.)))) (make-lambda-list (optp restp) `(,@required ,@(when (and optp optional) `(&optional ,@optional)) ,@(cond ((eq restp t) `(&rest ,rest)) ((null restp) `(c:&more .c. .n.)) (t nil)) ,@(when keyp `(&key)) ,@(when (and optp keys) `(,@keys)) ,@(when allowp `(&allow-other-keys)) ,@(when aux `(&aux ,@aux))))) (if (or restp keys optional) (multiple-value-bind (used-p rest-used-p) (uses-vars-p `(progn . ,body) optional keys rest env) (values (make-lambda-list used-p rest-used-p) (make-call-next rest-used-p))) (values (make-lambda-list nil :none) `(funcall (fwrapper-next fwrapper) ,@required)))) `(defun ,name (fwrapper) ,@(when documentation `(,documentation)) #'(kernel:instance-lambda ,lambda-list ,@declarations (flet ((%call-next-function () ,call-next)) (declare (ignorable #'%call-next-function)) (macrolet ((call-next-function (&rest args) (if args `(funcall (fwrapper-next fwrapper) ,@args) `(%call-next-function)))) ,@body)))))))) (defun uses-vars-p (body optionals keys rest env) "First value is true if BODY refers to any of the variables in OPTIONALS, KEYS or REST, which are what KERNEL:PARSE-LAMBDA-LIST returns. Second value is true if BODY refers to REST." (collect ((vars)) (dolist (v (append optionals keys)) (etypecase v (cons (destructuring-bind (v &optional value supplied-p) v (declare (ignore value)) (vars (if (consp v) (cadr v) v)) (when supplied-p (vars supplied-p)))) (symbol (vars v)))) (when rest (vars rest)) (let (used-p rest-used-p) (flet ((walk (form context env) (when (and (eq context :eval) (symbolp form) (memq form (vars)) (not (walker:variable-lexical-p form env))) (setq used-p t) (setq rest-used-p (or rest-used-p (eq form rest)))) form)) (walker:walk-form body env #'walk) (values used-p rest-used-p))))) ) ;;; ;;; Compatibility with old encapsulation API. ;;; (define-fwrapper encapsulation-fwrapper (&rest args) "Fwrapper for old-style encapsulations." (let ((basic-definition (fwrapper-next fwrapper)) (argument-list args)) (declare (special basic-definition argument-list)) (eval (fwrapper-user-data fwrapper)))) (defun encapsulate (name type body) "This function is deprecated; use fwrappers instead." (fwrap name #'encapsulation-fwrapper :type type :user-data body)) (defun unencapsulate (name type) "This function is deprecated; use fwrappers instead." (funwrap name :type type)) (defun encapsulated-p (name type) "This function is deprecated; use fwrappers instead." (not (null (find-fwrapper name :type type)))) ;;; end of file cmucl-21a/src/code/gc.lisp000066400000000000000000000510051260377556400155450ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/gc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Garbage collection and allocation related code. ;;; ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al. ;;; New code for MIPS port by Christopher Hoover. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook* *gc-notify-before* *gc-notify-after* get-bytes-consed *gc-run-time* bytes-consed-between-gcs get-bytes-consed-dfixnum)) (in-package "LISP") (export '(room)) #+gencgc (sys:register-lisp-runtime-feature :gencgc) ;;;; DYNAMIC-USAGE and friends. (declaim (special *read-only-space-free-pointer* *static-space-free-pointer*)) (eval-when (compile eval) (defmacro c-var-frob (lisp-fun c-var-name) `(progn (declaim (inline ,lisp-fun)) (defun ,lisp-fun () (alien:extern-alien ,c-var-name (alien:unsigned 32)))))) (c-var-frob read-only-space-start "read_only_space") (c-var-frob static-space-start "static_space") (c-var-frob dynamic-0-space-start "dynamic_0_space") (c-var-frob dynamic-1-space-start "dynamic_1_space") (c-var-frob control-stack-start "control_stack") #+x86 (c-var-frob control-stack-end "control_stack_end") (c-var-frob binding-stack-start "binding_stack") (c-var-frob current-dynamic-space-start "current_dynamic_space") (c-var-frob read-only-space-size "read_only_space_size") (c-var-frob binding-stack-size "binding_stack_size") (c-var-frob static-space-size "static_space_size") (c-var-frob control-stack-size "control_stack_size") (c-var-frob dynamic-space-size "dynamic_space_size") (declaim (inline dynamic-usage)) #-(or cgc gencgc) (defun dynamic-usage () (the (unsigned-byte 32) (- (system:sap-int (c::dynamic-space-free-pointer)) (current-dynamic-space-start)))) ;; #+(or cgc gencgc) ;; (c-var-frob dynamic-usage "bytes_allocated") #+gencgc (progn (alien:def-alien-routine get_bytes_allocated_lower c-call:int) (alien:def-alien-routine get_bytes_allocated_upper c-call:int) (defun dynamic-usage () (dfixnum:dfixnum-pair-integer (get_bytes_allocated_upper) (get_bytes_allocated_lower)))) #+cgc (c-var-frob dynamic-usage "bytes_allocated") (defun static-space-usage () (- (* lisp::*static-space-free-pointer* #-amd64 vm:word-bytes #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag (static-space-start))) (defun read-only-space-usage () (- (* lisp::*read-only-space-free-pointer* #-amd64 vm:word-bytes #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag (read-only-space-start))) (defun control-stack-usage () #-(or x86 amd64) (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)) #+(or x86 amd64) (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) ) (defun binding-stack-usage () (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start))) (defun current-dynamic-space () (let ((start (current-dynamic-space-start))) (cond ((= start (dynamic-0-space-start)) 0) ((= start (dynamic-1-space-start)) 1) (t (error (intl:gettext "Oh no. The current dynamic space is missing!")))))) ;;;; Room. (defun room-minimal-info () (flet ((megabytes (bytes) ;; Convert bytes to nearest megabyte (ceiling bytes (* 1024 1024)))) (format t (intl:gettext "Dynamic Space Usage: ~13:D bytes (out of ~4:D MB).~%") (dynamic-usage) (megabytes (dynamic-space-size))) (format t (intl:gettext "Read-Only Space Usage: ~13:D bytes (out of ~4:D MB).~%") (read-only-space-usage) (megabytes (read-only-space-size))) (format t (intl:gettext "Static Space Usage: ~13:D bytes (out of ~4:D MB).~%") (static-space-usage) (megabytes (static-space-size))) (format t (intl:gettext "Control Stack Usage: ~13:D bytes (out of ~4:D MB).~%") (control-stack-usage) (megabytes (control-stack-size))) (format t (intl:gettext "Binding Stack Usage: ~13:D bytes (out of ~4:D MB).~%") (binding-stack-usage) (megabytes (binding-stack-size))) (format t (intl:gettext "The current dynamic space is ~D.~%") (current-dynamic-space)) (format t (intl:gettext "Garbage collection is currently ~:[enabled~;DISABLED~].~%") *gc-inhibit*))) (defun room-intermediate-info () (room-minimal-info) (vm:memory-usage :count-spaces '(:dynamic) :print-spaces t :cutoff 0.05s0 :print-summary nil)) (defun room-maximal-info () (room-minimal-info) (vm:memory-usage :count-spaces '(:static :dynamic)) (vm:instance-usage :dynamic :top-n 10) (vm:instance-usage :static :top-n 10)) (defun room (&optional (verbosity :default)) "Prints to *STANDARD-OUTPUT* information about the state of internal storage and its management. The optional argument controls the verbosity of ROOM. If it is T, ROOM prints out a maximal amount of information. If it is NIL, ROOM prints out a minimal amount of information. If it is :DEFAULT or it is not supplied, ROOM prints out an intermediate amount of information. See also VM:MEMORY-USAGE and VM:INSTANCE-USAGE for finer report control." (fresh-line) (if (fboundp 'vm:memory-usage) (case verbosity ((t) (room-maximal-info)) ((nil) (room-minimal-info)) (:default (room-intermediate-info)) (t (error (intl:gettext "No way man! The optional argument to ROOM must be T, NIL, ~ or :DEFAULT.~%What do you think you are doing?")))) (room-minimal-info)) (values)) ;;;; GET-BYTES-CONSED. ;;; ;;; Internal State ;;; (defvar *last-bytes-in-use* nil) (defvar *total-bytes-consed* (dfixnum:make-dfixnum)) (declaim (type (or (unsigned-byte 32) null) *last-bytes-in-use*)) (declaim (type dfixnum:dfixnum *total-bytes-consed*)) ;;; GET-BYTES-CONSED -- Exported ;;; #+(or cgc gencgc) (defun get-bytes-consed-dfixnum () ;(declare (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (cond ((null *last-bytes-in-use*) (pushnew #'(lambda () (print (intl:gettext "resetting GC counters")) (force-output) (setf *last-bytes-in-use* nil) (setf *total-bytes-consed* (dfixnum:make-dfixnum))) ext:*before-save-initializations*) (setf *last-bytes-in-use* (dynamic-usage)) (dfixnum:dfixnum-set-from-number *total-bytes-consed* 0)) (t (let* ((bytes (dynamic-usage)) (incbytes (- bytes *last-bytes-in-use*))) (if (< incbytes dfixnum::dfmax) (dfixnum:dfixnum-inc-hf *total-bytes-consed* incbytes) (dfixnum:dfixnum-inc-df *total-bytes-consed* ;; Kinda fixme - we cons, but it doesn't matter if we consed ;; more than 250 Megabyte *within* this measuring period anyway. (let ((df (dfixnum:make-dfixnum))) (dfixnum:dfixnum-set-from-number df incbytes) df))) (setq *last-bytes-in-use* bytes)))) *total-bytes-consed*) #-(or cgc gencgc) (defun get-bytes-consed-dfixnum () _N"Returns the number of bytes consed since the first time this function was called. The first time it is called, it returns zero." (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3))) (cond ((null *last-bytes-in-use*) (setq *last-bytes-in-use* (dynamic-usage)) (setq *total-bytes-consed* (dfixnum:make-dfixnum))) (t (let ((bytes (dynamic-usage))) (dfixnum:dfixnum-inc-hf *total-bytes-consed* (the index (- bytes *last-bytes-in-use*))) (setq *last-bytes-in-use* bytes)))) *total-bytes-consed*) (defun get-bytes-consed () "Returns the number of bytes consed since the first time this function was called. The first time it is called, it returns zero." (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum))) ;;;; Variables and Constants. ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*. ;;; (defconstant default-bytes-consed-between-gcs 12000000) ;;; This variable is the user-settable variable that specifices the ;;; minimum amount of dynamic space which must be consed before a GC ;;; will be triggered. ;;; (defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs "This number specifies the minimum number of bytes of dynamic space that must be consed before the next gc will occur.") ;;; (declaim (type index *bytes-consed-between-gcs*)) ;;; Public (defvar *gc-run-time* 0 "The total CPU time spend doing garbage collection (as reported by GET-INTERNAL-RUN-TIME.)") (declaim (type index *gc-run-time*)) ;;; Internal trigger. When the dynamic usage increases beyond this ;;; amount, the system notes that a garbage collection needs to occur by ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning ;;; nobody has figured out what it should be yet. ;;; (defvar *gc-trigger* nil) (declaim (type (or (unsigned-byte 32) null) *gc-trigger*)) ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of ;;; letting magic C code handle it. It gets initialized by the startup ;;; code. The X86 port defines this here because it uses the `ibmrt' ;;; feature in the C code for allocation and binding stack access and ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well. #+(or ibmrt x86) (defvar vm::*internal-gc-trigger*) ;;; ;;; The following specials are used to control when garbage collection ;;; occurs. ;;; ;;; ;;; *GC-INHIBIT* ;;; ;;; When non-NIL, inhibits garbage collection. ;;; (defvar *gc-inhibit* nil) ;;; ;;; *ALREADY-MAYBE-GCING* ;;; ;;; This flag is used to prevent recursive entry into the garbage ;;; collector. ;;; (defvar *already-maybe-gcing* nil) ;;; When T, indicates that the dynamic usage has exceeded the value ;;; *GC-TRIGGER*. ;;; (defvar *need-to-collect-garbage* nil) ;;;; GC Hooks. ;;; ;;; *BEFORE-GC-HOOKS* ;;; *AFTER-GC-HOOKS* ;;; ;;; These variables are a list of functions which are run before and ;;; after garbage collection occurs. ;;; (defvar *before-gc-hooks* nil "A list of functions that are called before garbage collection occurs. The functions should take no arguments.") ;;; (defvar *after-gc-hooks* nil "A list of functions that are called after garbage collection occurs. The functions should take no arguments.") ;;; ;;; *GC-INHIBIT-HOOK* ;;; ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC ;;; was explicitly forced by calling EXT:GC). If the hook function ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T. ;;; Presumably someone will call GC-ON later to collect the garbage. ;;; (defvar *gc-inhibit-hook* nil "Should be bound to a function or NIL. If it is a function, this function should take one argument, the current amount of dynamic usage. The function should return NIL if garbage collection should continue and non-NIL if it should be inhibited. Use with caution.") ;;; ;;; *GC-VERBOSE* ;;; (defvar *gc-verbose* t "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* to be called before and after a garbage collection occurs respectively. If :BEEP, causes the default notify functions to beep annoyingly.") (defun default-gc-notify-before (bytes-in-use) (when (eq *gc-verbose* :beep) (system:beep *standard-output*)) (format t (intl:gettext "~&; [GC threshold exceeded with ~:D bytes in use. ~ Commencing GC.]~%") bytes-in-use) (finish-output)) ;;; (defparameter *gc-notify-before* #'default-gc-notify-before "This function bound to this variable is invoked before GC'ing (unless *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in bytes). It should notify the user that the system is going to GC.") (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger) (format t (intl:gettext "~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%") bytes-retained bytes-freed) (format t (intl:gettext "~&; [GC will next occur when at least ~:D bytes are in use.]~%") new-trigger) (when (eq *gc-verbose* :beep) (system:beep *standard-output*)) (finish-output)) ;;; (defparameter *gc-notify-after* #'default-gc-notify-after "The function bound to this variable is invoked after GC'ing (unless *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now free, the number of bytes freed by the GC, and the new GC trigger threshold. The function should notify the user that the system has finished GC'ing.") ;;;; Internal GC (alien:def-alien-routine collect-garbage c-call:int #+gencgc (last-gen c-call:int)) #-ibmrt (alien:def-alien-routine set-auto-gc-trigger c-call:void (dynamic-usage c-call:unsigned-long)) #+ibmrt (defun set-auto-gc-trigger (bytes) (let ((words (ash (+ (current-dynamic-space-start) bytes) -2))) (unless (and (fixnump words) (plusp words)) (clear-auto-gc-trigger) (warn (intl:gettext "Attempt to set GC trigger to something bogus: ~S") bytes)) (setf rt::*internal-gc-trigger* words))) #-ibmrt (alien:def-alien-routine clear-auto-gc-trigger c-call:void) #+ibmrt (defun clear-auto-gc-trigger () (setf rt::*internal-gc-trigger* -1)) ;;; ;;; *INTERNAL-GC* ;;; ;;; This variables contains the function that does the real GC. This is ;;; for low-level GC experimentation. Do not touch it if you do not ;;; know what you are doing. ;;; (defvar *internal-gc* #'collect-garbage) ;;;; SUB-GC ;;; ;;; CAREFULLY-FUNCALL -- Internal ;;; ;;; Used to carefully invoke hooks. ;;; (defmacro carefully-funcall (function &rest args) `(handler-case (funcall ,function ,@args) (error (cond) (warn (intl:gettext "(FUNCALL ~S~{ ~S~}) lost:~%~A") ',function ',args cond) nil))) ;;; ;;; SUB-GC -- Internal ;;; ;;; SUB-GC decides when and if to do a garbage collection. The ;;; VERBOSE-P flag controls whether or not the notify functions are ;;; called. The FORCE-P flags controls if a GC should occur even if the ;;; dynamic usage is not greater than *GC-TRIGGER*. ;;; ;;; For GENCGC all generations < GEN will be GC'ed. ;;; (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #+gencgc (gen 0)) (unless *already-maybe-gcing* (let* ((*already-maybe-gcing* t) (start-time (get-internal-run-time)) (pre-gc-dyn-usage (dynamic-usage))) (unless (integerp (symbol-value '*bytes-consed-between-gcs*)) ;; The noise w/ symbol-value above is to keep the compiler from ;; optimizing the test away because of the type declaim for ;; *bytes-consed-between-gcs*. (warn (intl:gettext "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~ integer. Resetting it to ~D.") *bytes-consed-between-gcs* default-bytes-consed-between-gcs) (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs)) (when (and *gc-trigger* (>= pre-gc-dyn-usage *gc-trigger*)) (setf *need-to-collect-garbage* t)) (when (or force-p (and *need-to-collect-garbage* (not *gc-inhibit*))) (when (and (not force-p) *gc-inhibit-hook* (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage)) (setf *gc-inhibit* t) (return-from sub-gc nil)) (without-interrupts (let ((*standard-output* *terminal-io*)) (when verbose-p (carefully-funcall *gc-notify-before* pre-gc-dyn-usage)) (dolist (hook *before-gc-hooks*) (carefully-funcall hook)) (when *gc-trigger* (clear-auto-gc-trigger)) #-gencgc (funcall *internal-gc*) #+gencgc (if (eq *internal-gc* #'collect-garbage) (funcall *internal-gc* gen) (funcall *internal-gc*)) (let* ((post-gc-dyn-usage (dynamic-usage)) (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage))) (when *last-bytes-in-use* #+nil (when verbose-p (format t (intl:gettext "~&Adjusting *last-bytes-in-use* from ~:D to ~:D, gen ~d, pre ~:D ~%") *last-bytes-in-use* post-gc-dyn-usage gen pre-gc-dyn-usage) (force-output)) (let ((correction (- pre-gc-dyn-usage *last-bytes-in-use*))) (if (<= correction dfixnum::dfmax) (dfixnum:dfixnum-inc-hf *total-bytes-consed* correction) ;; give up on not consing (dfixnum:dfixnum-inc-integer *total-bytes-consed* correction))) (setq *last-bytes-in-use* post-gc-dyn-usage)) (setf *need-to-collect-garbage* nil) (setf *gc-trigger* (+ post-gc-dyn-usage *bytes-consed-between-gcs*)) (set-auto-gc-trigger *gc-trigger*) (dolist (hook *after-gc-hooks*) (carefully-funcall hook)) (when verbose-p (carefully-funcall *gc-notify-after* post-gc-dyn-usage bytes-freed *gc-trigger*)))) (scrub-control-stack))) (incf *gc-run-time* (- (get-internal-run-time) start-time)))) nil) ;;; ;;; MAYBE-GC -- Internal ;;; ;;; This routine is called by the allocation miscops to decide if a GC ;;; should occur. The argument, object, is the newly allocated object ;;; which must be returned to the caller. ;;; (defun maybe-gc (&optional object) (sub-gc) object) ;;; ;;; GC -- Exported ;;; ;;; This is the user advertised garbage collection function. ;;; #-gencgc (defun gc (&optional (verbose-p *gc-verbose*)) _N"Initiates a garbage collection. The optional argument, VERBOSE-P, which defaults to the value of the variable *GC-VERBOSE* controls whether or not GC statistics are printed." (sub-gc :verbose-p verbose-p :force-p t)) ;;; #+gencgc (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil)) _N"Initiates a garbage collection. The keyword :VERBOSE, which defaults to the value of the variable *GC-VERBOSE* controls whether or not GC statistics are printed. The keyword :GEN defaults to 0, and controls the number of generations to garbage collect." (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen))) ;;;; Auxiliary Functions. (defun bytes-consed-between-gcs () "Return the amount of memory that will be allocated before the next garbage collection is initiated. This can be set with SETF." *bytes-consed-between-gcs*) ;;; (defun %set-bytes-consed-between-gcs (val) (declare (type index val)) (let ((old *bytes-consed-between-gcs*)) (setf *bytes-consed-between-gcs* val) (when *gc-trigger* (setf *gc-trigger* (+ *gc-trigger* (- val old))) (cond ((<= (dynamic-usage) *gc-trigger*) (clear-auto-gc-trigger) (set-auto-gc-trigger *gc-trigger*)) (t (system:scrub-control-stack) (sub-gc))))) val) ;;; (defsetf bytes-consed-between-gcs %set-bytes-consed-between-gcs) (defun gc-on () "Enables the garbage collector." (setq *gc-inhibit* nil) (when *need-to-collect-garbage* (sub-gc)) nil) (defun gc-off () "Disables the garbage collector." (setq *gc-inhibit* t) nil) ;;;; Initialization stuff. (defun gc-init () (when *gc-trigger* (if (< *gc-trigger* (dynamic-usage)) (sub-gc) (set-auto-gc-trigger *gc-trigger*)))) ;;; setters and accessors for gencgc parameters #+gencgc (eval-when (load eval) (alien:def-alien-type nil (alien:struct generation-stats (bytes-allocated c-call:int) (gc-trigger c-call:int) (bytes-consed-between-gc c-call:int) (num-gc c-call:int) (trigger-age c-call:int) (cum-sum-bytes-allocated c-call:int) (min-av-mem-age c-call:int))) (defun gencgc-stats (generation) "Return some GC statistics for the specified GENERATION. The statistics are the number of bytes allocated in this generation; the gc-trigger; the number of bytes consed between GCs; the number of GCs that have occurred; the trigger age; the cumulative number of bytes allocated in this generation; and the average age of this generation. See the gencgc source code for more info." (alien:with-alien ((stats (alien:struct generation-stats))) (alien:alien-funcall (alien:extern-alien "get_generation_stats" (function c-call:void c-call:int (* (alien:struct generation-stats)))) generation (alien:addr stats)) (values (alien:slot stats 'bytes-allocated) (alien:slot stats 'gc-trigger) (alien:slot stats 'bytes-consed-between-gc) (alien:slot stats 'num-gc) (alien:slot stats 'trigger-age) (alien:slot stats 'cum-sum-bytes-allocated) (alien:slot stats 'min-av-mem-age)))) (alien:def-alien-routine set-gc-trigger c-call:void (gen c-call:int) (trigger c-call:int)) (alien:def-alien-routine set-trigger-age c-call:void (gen c-call:int) (trigger-age c-call:int)) (alien:def-alien-routine set-min-mem-age c-call:void (gen c-call:int) (min-mem-age c-call:double)) (alien:def-alien-routine set-max-gen-to-gc c-call:unsigned-int (gen c-call:int)) ) cmucl-21a/src/code/generic-site.lisp000066400000000000000000000035551260377556400175410ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: System -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/generic-site.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file is installed as "library:site-init" in binary ;;; distributions of CMUCL. ;;; (in-package "SYSTEM") ;;; Put your site name here... (setq *short-site-name* "Unknown") (setq *long-site-name* "Site name not initialized") ;;; We would appreciate it if each site establishes a local maintainer who can ;;; filter bug reports from novice users to make sure that they really have ;;; found a bug. Fill in the maintainer's address here.. (when *herald-items* (rplaca (cdr (member :bugs *herald-items*)) '("Send questions and bug reports to your local CMUCL maintainer, " terpri "or see ." terpri "Loaded subsystems:" terpri))) ;;; If you have sources installed on your system, un-comment the following form ;;; and change it to point to the source location. This will allow the Hemlock ;;; "Edit Definition" command and the debugger to find sources for functions in ;;; the core. ;;; ;;; The definition below assumes the default tree structure in a CMUCL ;;; distribution: ;;; ;;; top ;;; bin/ ;;; lib/ ;;; cmucl/ ;;; lib/ ;;; lisp*.coore ;;; man/ ;;; src/ ;;; ;;; If your sources are located somewhere else, change this ;;; accordingly. #| (setf (search-list "target:") (list (namestring (make-pathname :directory (pathname-directory (merge-pathnames (make-pathname :directory '(:relative :up :up :up "src")) (pathname lisp::*cmucl-core-path*))))))) |# cmucl-21a/src/code/gengc.lisp000066400000000000000000000073471260377556400162510ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/gengc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Lisp level interface to the Generational Garbage Collector. ;;; ;;; Written by William Lott. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(*before-gc-hooks* *after-gc-hooks* gc purify *gc-verbose* *gc-notify-before* *gc-notify-after*)) (in-package "LISP") ;;;; GC Hooks. ;;; ;;; *BEFORE-GC-HOOKS* ;;; *AFTER-GC-HOOKS* ;;; ;;; These variables are a list of functions which are run before and ;;; after garbage collection occurs. ;;; (defvar *before-gc-hooks* nil "A list of functions that are called before garbage collection occurs. The functions should take no arguments.") ;;; (defvar *after-gc-hooks* nil "A list of functions that are called after garbage collection occurs. The functions should take no arguments.") ;;; *GC-VERBOSE* -- interface ;;; (defvar *gc-verbose* t "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* to be called before and after a garbage collection occurs respectively. If :BEEP, causes the default notify functions to beep annoyingly.") (defun default-gc-notify-before (bytes-in-use) (when (eq *gc-verbose* :beep) (system:beep *standard-output*)) (format t "~&[GC threshold exceeded with ~:D bytes in use. ~ Commencing GC.]~%" bytes-in-use) (finish-output)) ;;; (defparameter *gc-notify-before* #'default-gc-notify-before "This function bound to this variable is invoked before GC'ing (unless *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in bytes). It should notify the user that the system is going to GC.") (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger) (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%" bytes-retained bytes-freed) (format t "[GC will next occur when at least ~:D bytes are in use.]~%" new-trigger) (when (eq *gc-verbose* :beep) (system:beep *standard-output*)) (finish-output)) ;;; (defparameter *gc-notify-after* #'default-gc-notify-after "The function bound to this variable is invoked after GC'ing (unless *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now free, the number of bytes freed by the GC, and the new GC trigger threshold. The function should notify the user that the system has finished GC'ing.") ;;; CAREFULLY-FUNCALL -- Internal ;;; ;;; Used to carefully invoke hooks. ;;; (defmacro carefully-funcall (function &rest args) `(handler-case (funcall ,function ,@args) (error (cond) (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond) nil))) ;;; DO-BEFORE-GC-STUFF -- interface. ;;; ;;; Called by the C code just before doing a GC. ;;; (defun do-before-gc-stuff () (when *gc-verbose* (carefully-funcall *gc-notify-before* 0)) (dolist (hook *before-gc-hooks*) (carefully-funcall hook)) nil) ;;; DO-AFTER-GC-STUFF -- interface. ;;; ;;; Called by the C code just after doing a GC. ;;; (defun do-after-gc-stuff () (dolist (hook *after-gc-hooks*) (carefully-funcall hook)) (when *gc-verbose* (carefully-funcall *gc-notify-after* 0 0 0)) nil) ;;;; Interface to GC routines (alien:def-alien-routine ("collect_garbage" gc) c-call:void "Force a garbage collection.") (defun purify (&key root-structures constants) (declare (ignore root-structures constants)) (gc)) (defun gc-init () ;; Nothing to do. (undefined-value)) cmucl-21a/src/code/globals.lisp000066400000000000000000000060141260377556400165770ustar00rootroot00000000000000;;; -*- Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/globals.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains special proclamations for variables that are ;;; referenced in the code sources before they are defined. There is also a ;;; function proclamation to make some common functions be known, avoiding ;;; large amounts of work in recording the calls that are done before the ;;; definition. ;;; ;;; Written by Rob MacLachlan ;;; (in-package "LISP") (intl:textdomain "cmucl") (declaim (special *keyword-package* *lisp-package* *package* *query-io* *terminal-io* *error-output* *trace-output* *debug-io* *standard-input* *standard-output* *evalhook* *applyhook* *command-line-switches* *command-switch-demons* *display-event-handlers* original-lisp-environment *environment-list* *read-default-float-format* *read-suppress* *readtable* *print-base* *print-radix* *print-length* *print-level* *print-pretty* *print-escape* *print-case* *print-circle* *print-gensym* *print-array* defmacro-error-string defsetf-error-string std-lisp-readtable #-no-hemlock hi::*in-the-editor* debug::*in-the-debugger* conditions::*handler-clusters* conditions::*restart-clusters* *gc-inhibit* *need-to-collect-garbage* defmacro-error-string deftype-error-string defsetf-error-string %sp-interrupts-inhibited *software-interrupt-vector* *load-verbose* *load-print-stuff* *in-compilation-unit* *aborted-compilation-units* char-name-alist *default-pathname-defaults* *beep-function* *gc-notify-before* *gc-notify-after*)) (declaim (ftype (function * *) find-keyword keyword-test assert-error assert-prompt check-type-error case-body-error print-object describe-object pcl::check-wrapper-validity)) #-clx (declaim (ftype (function * *) disable-clx-event-handling extensions::call-display-event-handler xlib::display-input-stream xlib::event-listen flush-display-events)) #-hemlock (declaim (ftype (function * *) hemlock-internals::current-window hemlock-internals::device-exit hemlock-internals::device-hunk-device hemlock-internals::device-init hemlock::ts-stream-p hemlock::ts-stream-wire hemlock-internals::window-hunk)) ;;; Gray streams functions not defined until after PCL is loaded. (declaim (ftype (function * *) stream-advance-to-column stream-clear-input stream-clear-output stream-finish-output stream-force-output stream-fresh-line stream-line-column stream-line-length stream-listen stream-peek-char stream-read-byte stream-read-char stream-read-char-no-hang stream-read-line stream-start-line-p stream-terpri stream-unread-char stream-write-byte stream-write-char stream-write-string stream-read-sequence stream-write-sequence)) cmucl-21a/src/code/hash-new.lisp000066400000000000000000001264411260377556400166750ustar00rootroot00000000000000;;; -*- Package: CL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/hash-new.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Hashing and hash table functions for Spice Lisp. ;;; Originally written by Skef Wholey. ;;; Everything except SXHASH rewritten by William Lott. ;;; Hash table functions rewritten by Douglas Crosher, 1997. ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000. ;;; (in-package :lisp) (intl:textdomain "cmucl") (export '(hash-table hash-table-p make-hash-table gethash remhash maphash clrhash hash-table-count with-hash-table-iterator hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test sxhash)) (in-package :ext) (export '(define-hash-table-test)) (in-package :lisp) (register-lisp-runtime-feature :hash-new) ;;;; The hash-table structures. ;;; HASH-TABLE -- defstruct. ;;; (defstruct (hash-table (:constructor %make-hash-table) (:print-function %print-hash-table) (:make-load-form-fun make-hash-table-load-form)) _N"Structure used to implement hash tables." ;; ;; The type of hash table this is. Only used for printing and as part of ;; the exported interface. (test (required-argument) :type symbol :read-only t) ;; ;; The function used to compare two keys. Returns T if they are the same ;; and NIL if not. (test-fun (required-argument) :type function :read-only t) ;; ;; The function used to compute the hashing of a key. Returns two values: ;; the index hashing and T if that might change with the next GC. (hash-fun (required-argument) :type function :read-only t) ;; ;; How much to grow the hash table by when it fills up. If an index, then ;; add that amount. If a floating point number, then multiply it by that. (rehash-size (required-argument) :type (or index (single-float (1.0))) :read-only t) ;; ;; How full the hash table has to get before we rehash. (rehash-threshold (required-argument) :type (single-float (0.0) 1.0) :read-only t) ;; ;; The number of entries before a rehash, just the one less than the ;; size of the next-vector, hash-vector, and half the size of the ;; kv-vector. (rehash-trigger (required-argument) :type index) ;; ;; The current number of entries in the table. (number-entries 0 :type index) ;; ;; The Key-Value pair vector. (table (required-argument) :type simple-vector) ;; ;; Non-nil if this is a weak hash table. Four separate types of ;; weakness are supported: :key, :value, :key-and-value, ;; :key-or-value. The entry in the table is retained if the key, ;; (respectively, value, key and value, key or value) is alive ;; because it is referenced elsewhere. If the condition does not ;; hold, the entry is removed. For tables with a weak key, EQL or ;; EQ must be used as the test. (weak-p nil :type (member nil :key :value :key-and-value :key-or-value)) ;; ;; Index into the next-vector, chaining together buckets that need ;; to be rehashed because their hashing is EQ based and the key has ;; been moved by the garbage collector. (needing-rehash 0 :type index) ;; ;; Index into the Next vector chaining together free slots in the KV ;; vector. (next-free-kv 0 :type index) ;; ;; The index vector. This may be larger than the hash size to help ;; reduce collisions. (index-vector (required-argument) :type (simple-array (unsigned-byte 32) (*))) ;; ;; This table parallels the KV vector, and is used to chain together ;; the hash buckets, the free list, and the values needing rehash, a ;; slot will only ever be in one of these lists. (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*))) ;; ;; This table parallels the KV table, and can be used to store the ;; hash associated with the key, saving recalculation. Could be ;; useful for EQL, and EQUAL hash tables. This table is not needed ;; for EQ hash tables (and is NIL in that case), and when present the ;; value of #x8000000 represents EQ-based hashing on the respective ;; Key. (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*)))) ;; ;; This is used by GC to chain the list of weak hash tables ;; together. It should otherwise always be NIL. (next-weak-table nil :type (or null hash-table))) ;;; (defun %print-hash-table (ht stream depth) (declare (ignore depth) (stream stream)) (print-unreadable-object (ht stream :type t :identity t) (format stream "~S ~S ~S ~S ~S ~D" :test (hash-table-test ht) :weak-p (hash-table-weak-p ht) :count (hash-table-number-entries ht)))) (defconstant max-hash most-positive-fixnum) (deftype hash () `(integer 0 ,max-hash)) ;; This value in the hash-vector indicates the the key uses EQ-based ;; hashing (i.e., either EQ or EQL). (defconstant +eq-based-hash-value+ #x80000000) ;;;; Utility functions. (declaim (inline pointer-hash)) (defun pointer-hash (key) (declare (values hash)) (truly-the hash (%primitive make-fixnum key))) (declaim (inline eq-hash)) (defun eq-hash (key) (declare (values hash (member t nil))) (values (pointer-hash key) (oddp (get-lisp-obj-address key)))) (declaim (inline eql-hash)) (defun eql-hash (key) (declare (values hash (member t nil))) (if (numberp key) (equal-hash key) (eq-hash key))) (declaim (inline equal-hash)) (defun equal-hash (key) (declare (values hash (member t nil))) (values (sxhash key) nil)) (defun equalp-hash (key) (declare (values hash (member t nil))) (values (internal-equalp-hash key 0) nil)) (defun almost-primify (num) (declare (type index num)) "Almost-Primify returns an almost prime number greater than or equal to NUM." (if (= (rem num 2) 0) (setq num (+ 1 num))) (if (= (rem num 3) 0) (setq num (+ 2 num))) (if (= (rem num 7) 0) (setq num (+ 4 num))) num) ;;;; User defined hash table tests. ;;; *HASH-TABLE-TESTS* -- Internal. ;;; (defvar *hash-table-tests* nil) ;;; DEFINE-HASH-TABLE-TEST -- Public. ;;; (defun define-hash-table-test (name test-fun hash-fun) "Define a new kind of hash table test." (declare (type symbol name) (type function test-fun hash-fun)) (setf *hash-table-tests* (cons (list name test-fun hash-fun) (remove name *hash-table-tests* :test #'eq :key #'car))) name) ;;;; Construction and simple accessors. ;;; MAKE-HASH-TABLE -- public. ;;; (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5) (rehash-threshold 1.0) (weak-p nil)) "Creates and returns a new hash table. The keywords are as follows: :TEST -- Indicates what kind of test to use. Only EQ, EQL, EQUAL, and EQUALP are currently supported. :SIZE -- A hint as to how many elements will be put in this hash table. :REHASH-SIZE -- Indicates how to expand the table when it fills up. If an integer, add space for that many elements. If a floating point number (which must be greater than 1.0), multiple the size by that amount. :REHASH-THRESHOLD -- Indicates how dense the table can become before forcing a rehash. Can be any positive number <= to 1, with density approaching zero as the threshold approaches 0. Density 1 means an average of one entry per bucket. CMUCL Extension: :WEAK-P -- Weak hash table. Can only be used when the key is 'eq or 'eql. An entry in the table is remains if the condition holds: :KEY -- key is referenced elsewhere :VALUE -- value is referenced elsewhere :KEY-AND-VALUE -- key and value are referenced elsewhere :KEY-OR-VALUE -- key or value is referenced elsewhere If the condition does not hold, the entry is removed. For backward compatibility, a value of T is the same as :KEY." (declare (type (or function symbol) test) (type index size) (type (member t nil :key :value :key-and-value :key-or-value) weak-p)) (let ((rehash-size (if (integerp rehash-size) rehash-size (float rehash-size 1.0)))) (when (eq weak-p t) (setf weak-p :key)) (multiple-value-bind (test test-fun hash-fun) (cond ((or (eq test #'eq) (eq test 'eq)) (values 'eq #'eq #'eq-hash)) ((or (eq test #'eql) (eq test 'eql)) (values 'eql #'eql #'eql-hash)) ((or (eq test #'equal) (eq test 'equal)) (values 'equal #'equal #'equal-hash)) ((or (eq test #'equalp) (eq test 'equalp)) (values 'equalp #'equalp #'equalp-hash)) (t (dolist (info *hash-table-tests* (error 'simple-program-error :format-control (intl:gettext "Unknown :TEST for MAKE-HASH-TABLE: ~S") :format-arguments (list test))) (destructuring-bind (test-name test-fun hash-fun) info (when (or (eq test test-name) (eq test test-fun)) (return (values test-name test-fun hash-fun))))))) (let* ((size (max 36 size)) ; Needs to be at least 1, say 36. (size+1 (1+ size)) ; The first element is not usable. ;; Don't let rehash-threshold get too small to cause ;; overflows or division by zero. It's a hint, not a ;; requirement, anyway. (rehash-threshold (float (max 0.1 rehash-threshold) 1.0)) (scaled-size (round (/ (float size+1) rehash-threshold))) (length (if (<= scaled-size 37) 37 (almost-primify scaled-size)))) (declare (type index size+1 scaled-size length)) #-gencgc (when weak-p (format *debug-io* (intl:gettext ";; Creating unsupported weak-p hash table~%"))) #+gencgc (when (and (member weak-p '(t :key :key-and-value :key-or-value)) (not (member test '(eq eql)))) ;; I (rtoy) think the current GENCGC code really expects the ;; test to be EQ, but doesn't enforce it in any way. Let's ;; warn about it for now. ;; ;; XXX: Either fix GC to work with other tests, or change ;; this warning into an error. (error (intl:gettext "Cannot make a weak ~A hashtable with test: ~S") weak-p test)) (let* ((index-vector (make-array length :element-type '(unsigned-byte 32) :initial-element 0)) ;; Needs to be the same length as the KV vector (next-vector (make-array size+1 :element-type '(unsigned-byte 32))) (kv-vector (make-array (* 2 size+1) :initial-element 'empty-hash-entry)) (table (%make-hash-table :test test :test-fun test-fun :hash-fun hash-fun :rehash-size rehash-size :rehash-threshold rehash-threshold :rehash-trigger size :table kv-vector :weak-p weak-p :index-vector index-vector :next-vector next-vector :hash-vector (unless (eq test 'eq) (make-array size+1 :element-type '(unsigned-byte 32) :initial-element +eq-based-hash-value+))))) ;; Setup the free list, all free. These lists are 0 ;; terminated. (do ((i 1 (1+ i))) ((>= i size)) (setf (aref next-vector i) (1+ i))) (setf (aref next-vector size) 0) (setf (hash-table-next-free-kv table) 1) (setf (hash-table-needing-rehash table) 0) (setf (aref kv-vector 0) table) table))))) (declaim (inline hash-table-count)) (defun hash-table-count (hash-table) "Returns the number of entries in the given HASH-TABLE." (declare (type hash-table hash-table) (values index)) (hash-table-number-entries hash-table)) (setf (documentation 'hash-table-rehash-size 'function) _N"Return the rehash-size HASH-TABLE was created with.") (setf (documentation 'hash-table-rehash-threshold 'function) _N"Return the rehash-threshold HASH-TABLE was created with.") (declaim (inline hash-table-size)) (defun hash-table-size (hash-table) "Return a size that can be used with MAKE-HASH-TABLE to create a hash table that can hold however many entries HASH-TABLE can hold without having to be grown." (hash-table-rehash-trigger hash-table)) (setf (documentation 'hash-table-test 'function) _N"Return the test HASH-TABLE was created with.") (setf (documentation 'hash-table-weak-p 'function) _N"Return T if HASH-TABLE will not keep entries for keys that would otherwise be garbage, and NIL if it will.") ;;;; Accessing functions. ;;; REHASH -- internal. ;;; ;;; Make new vectors for the table, extending the table based on the ;;; rehash-size. ;;; (defun rehash (table) (declare (type hash-table table)) (let* ((old-kv-vector (hash-table-table table)) (old-next-vector (hash-table-next-vector table)) (old-hash-vector (hash-table-hash-vector table)) (old-size (length old-next-vector)) (new-size (let ((rehash-size (hash-table-rehash-size table))) (etypecase rehash-size (fixnum (+ rehash-size old-size)) (float (the (values index t) (round (* rehash-size old-size))))))) (new-kv-vector (make-array (* 2 new-size) :initial-element 'empty-hash-entry)) (new-next-vector (make-array new-size :element-type '(unsigned-byte 32) :initial-element 0)) (new-hash-vector (when old-hash-vector (make-array new-size :element-type '(unsigned-byte 32) :initial-element +eq-based-hash-value+))) (old-index-vector (hash-table-index-vector table)) (new-length (almost-primify (round (/ (float new-size) (hash-table-rehash-threshold table))))) (new-index-vector (make-array new-length :element-type '(unsigned-byte 32) :initial-element 0))) (declare (type index new-size new-length old-size)) ;; Disable GC tricks on the old-kv-vector. (set-header-data old-kv-vector vm:vector-normal-subtype) ;; Copy over the kv-vector, the element positions should not move ;; in case there are active scans. (dotimes (i (* old-size 2)) (declare (type index i)) (setf (aref new-kv-vector i) (aref old-kv-vector i))) ;; Copy over the hash-vector. (when old-hash-vector (dotimes (i old-size) (setf (aref new-hash-vector i) (aref old-hash-vector i)))) (setf (hash-table-next-free-kv table) 0) (setf (hash-table-needing-rehash table) 0) ;; Rehash all the entries; last to first so that after the pushes ;; the chains are first to last. (do ((i (1- new-size) (1- i)) (empty (aref new-kv-vector 1))) ((zerop i)) (let ((key (aref new-kv-vector (* 2 i))) (value (aref new-kv-vector (1+ (* 2 i))))) ;; A slot is empty if both the key and the value are "empty", ;; which is indicated by the value of kv_vector[1]. (cond ((and (eq key empty) (eq value empty)) ;; Push this slot onto the free list. (setf (aref new-next-vector i) (hash-table-next-free-kv table)) (setf (hash-table-next-free-kv table) i)) ((and new-hash-vector (not (= (aref new-hash-vector i) +eq-based-hash-value+))) ;; Can use the existing hash value (not EQ based) (let* ((hashing (aref new-hash-vector i)) (index (rem hashing new-length)) (next (aref new-index-vector index))) (declare (type index index) (type hash hashing)) ;; Push this slot into the next chain. (setf (aref new-next-vector i) next) (setf (aref new-index-vector index) i))) (t ;; EQ base hash. ;; Enable GC tricks. (set-header-data new-kv-vector vm:vector-valid-hashing-subtype) (let* ((hashing (pointer-hash key)) (index (rem hashing new-length)) (next (aref new-index-vector index))) (declare (type index index) (type hash hashing)) ;; Push this slot onto the next chain. (setf (aref new-next-vector i) next) (setf (aref new-index-vector index) i)))))) (setf (hash-table-table table) new-kv-vector) (setf (hash-table-index-vector table) new-index-vector) (setf (hash-table-next-vector table) new-next-vector) (setf (hash-table-hash-vector table) new-hash-vector) ;; Shrink the old vectors to 0 size to help the conservative GC. (setf old-kv-vector (shrink-vector old-kv-vector 0)) (setf old-index-vector (shrink-vector old-index-vector 0)) (setf old-next-vector (shrink-vector old-next-vector 0)) (when old-hash-vector (setf old-hash-vector (shrink-vector old-hash-vector 0))) (setf (hash-table-rehash-trigger table) new-size)) (undefined-value)) ;;; REHASH-WITHOUT-GROWING -- internal. ;;; ;;; Use the same size as before, re-using the vectors. ;;; (defun rehash-without-growing (table) (declare (type hash-table table)) (let* ((kv-vector (hash-table-table table)) (next-vector (hash-table-next-vector table)) (hash-vector (hash-table-hash-vector table)) (size (length next-vector)) (index-vector (hash-table-index-vector table)) (length (length index-vector))) (declare (type index size length) (type (simple-array (unsigned-byte 32) (*)))) ;; Disable GC tricks, they will be re-enabled during the re-hash ;; if necesary. (set-header-data kv-vector vm:vector-normal-subtype) ;; Rehash all the entries. (setf (hash-table-next-free-kv table) 0) (setf (hash-table-needing-rehash table) 0) (dotimes (i size) (setf (aref next-vector i) 0)) (dotimes (i length) (setf (aref index-vector i) 0)) (do ((i (1- size) (1- i)) (empty (aref kv-vector 1))) ((zerop i)) (let ((key (aref kv-vector (* 2 i))) (value (aref kv-vector (1+ (* 2 i))))) ;; A slot is empty if both the key and the value are "empty", ;; which is indicated by the value of kv_vector[1]. (cond ((and (eq key empty) (eq value empty)) ;; Push this slot onto the free list. (setf (aref next-vector i) (hash-table-next-free-kv table)) (setf (hash-table-next-free-kv table) i)) ((and hash-vector (not (= (aref hash-vector i) +eq-based-hash-value+))) ;; Can use the existing hash value (not EQ based) (let* ((hashing (aref hash-vector i)) (index (rem hashing length)) (next (aref index-vector index))) (declare (type index index)) ;; Push this slot into the next chain. (setf (aref next-vector i) next) (setf (aref index-vector index) i))) (t ;; EQ base hash. ;; Enable GC tricks. (set-header-data kv-vector vm:vector-valid-hashing-subtype) (let* ((hashing (pointer-hash key)) (index (rem hashing length)) (next (aref index-vector index))) (declare (type index index) (type hash hashing)) ;; Push this slot into the next chain. (setf (aref next-vector i) next) (setf (aref index-vector index) i))))))) (undefined-value)) (defun flush-needing-rehash (table) (let* ((kv-vector (hash-table-table table)) (index-vector (hash-table-index-vector table)) (next-vector (hash-table-next-vector table)) (length (length index-vector))) (do ((next (hash-table-needing-rehash table))) ((zerop next)) (declare (type index next)) (let* ((key (aref kv-vector (* 2 next))) (hashing (pointer-hash key)) (index (rem hashing length)) (temp (aref next-vector next))) (setf (aref next-vector next) (aref index-vector index)) (setf (aref index-vector index) next) (setf next temp)))) (setf (hash-table-needing-rehash table) 0) (undefined-value)) ;;; GETHASH -- Public. ;;; (defun gethash (key hash-table &optional default) "Finds the entry in HASH-TABLE whose key is KEY and returns the associated value and T as multiple values, or returns DEFAULT and NIL if there is no such entry. Entries can be added using SETF." (declare (type hash-table hash-table) (values t (member t nil))) (without-gcing (cond ((= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash-without-growing hash-table)) ((not (zerop (hash-table-needing-rehash hash-table))) (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) (length (length index-vector)) (index (rem hashing length)) (next (aref index-vector index)) (table (hash-table-table hash-table)) (next-vector (hash-table-next-vector hash-table)) (hash-vector (hash-table-hash-vector hash-table)) (test-fun (hash-table-test-fun hash-table))) (declare (type index index)) ;; Search next-vector chain for a matching key. (if (or eq-based (not hash-vector)) (do ((next next (aref next-vector next))) ((zerop next) (values default nil)) (declare (type index next)) (when (eq key (aref table (* 2 next))) (return (values (aref table (1+ (* 2 next))) t)))) (do ((next next (aref next-vector next))) ((zerop next) (values default nil)) (declare (type index next)) (when (and (= hashing (aref hash-vector next)) (funcall test-fun key (aref table (* 2 next)))) ;; Found. (return (values (aref table (1+ (* 2 next))) t))))))))) ;;; So people can call #'(setf gethash). ;;; (defun (setf gethash) (new-value key table &optional default) (declare (ignore default)) (%puthash key table new-value)) ;;; %PUTHASH -- public setf method. ;;; (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) (assert (hash-table-index-vector hash-table)) (without-gcing ;; Need to rehash here so that a current key can be found if it ;; exists. Check that there is room for one more entry. May not be ;; needed if the key is already present. (cond ((zerop (hash-table-next-free-kv hash-table)) (rehash hash-table)) ((= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash-without-growing hash-table)) ((not (zerop (hash-table-needing-rehash hash-table))) (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) (length (length index-vector)) (index (rem hashing length)) (next (aref index-vector index)) (kv-vector (hash-table-table hash-table)) (next-vector (hash-table-next-vector hash-table)) (hash-vector (hash-table-hash-vector hash-table)) (test-fun (hash-table-test-fun hash-table))) (declare (type index index)) (cond ((or eq-based (not hash-vector)) (when eq-based (set-header-data kv-vector vm:vector-valid-hashing-subtype)) ;; Search next-vector chain for a matching key. (do ((next next (aref next-vector next))) ((zerop next)) (declare (type index next)) (when (eq key (aref kv-vector (* 2 next))) ;; Found, just replace the value. (setf (aref kv-vector (1+ (* 2 next))) value) (return-from %puthash value)))) (t ;; Search next-vector chain for a matching key. (do ((next next (aref next-vector next))) ((zerop next)) (declare (type index next)) (when (and (= hashing (aref hash-vector next)) (funcall test-fun key (aref kv-vector (* 2 next)))) ;; Found, just replace the value. (setf (aref kv-vector (1+ (* 2 next))) value) (return-from %puthash value))))) ;; Pop a KV slot off the free list (let ((free-kv-slot (hash-table-next-free-kv hash-table))) ;; Double-check for overflow. (assert (not (zerop free-kv-slot))) (setf (hash-table-next-free-kv hash-table) (aref next-vector free-kv-slot)) (incf (hash-table-number-entries hash-table)) (setf (aref kv-vector (* 2 free-kv-slot)) key) (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) ;; Setup the hash-vector if necessary. (when hash-vector (if (not eq-based) (setf (aref hash-vector free-kv-slot) hashing) (assert (= (aref hash-vector free-kv-slot) +eq-based-hash-value+)))) ;; Push this slot into the next chain. (setf (aref next-vector free-kv-slot) next) (setf (aref index-vector index) free-kv-slot))))) value) ;;; REMHASH -- public. ;;; (defun remhash (key hash-table) "Remove the entry in HASH-TABLE associated with KEY. Returns T if there was such an entry, and NIL if not." (declare (type hash-table hash-table) (values (member t nil))) (without-gcing ;; Need to rehash here so that a current key can be found if it ;; exists. (cond ((= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash-without-growing hash-table)) ((not (zerop (hash-table-needing-rehash hash-table))) (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) (length (length index-vector)) (index (rem hashing length)) (next (aref index-vector index)) (table (hash-table-table hash-table)) (next-vector (hash-table-next-vector hash-table)) (hash-vector (hash-table-hash-vector hash-table)) (test-fun (hash-table-test-fun hash-table)) (empty (aref table 1))) (declare (type index index next)) (cond ((zerop next) nil) ((if (or eq-based (not hash-vector)) (eq key (aref table (* 2 next))) (and (= hashing (aref hash-vector next)) (funcall test-fun key (aref table (* 2 next))))) ;; Empty out Key and Value, by using the empty value in ;; kv-vector[1]. (setf (aref table (* 2 next)) empty) (setf (aref table (1+ (* 2 next))) empty) ;; Update the index-vector pointer. (setf (aref index-vector index) (aref next-vector next)) ;; Push KV slot onto free chain. (setf (aref next-vector next) (hash-table-next-free-kv hash-table)) (setf (hash-table-next-free-kv hash-table) next) (when hash-vector (setf (aref hash-vector next) +eq-based-hash-value+)) (decf (hash-table-number-entries hash-table)) t) ;; Search next-vector chain for a matching key. ((or eq-based (not hash-vector)) ;; EQ based. (do ((prior next next) (next (aref next-vector next) (aref next-vector next))) ((zerop next) nil) (declare (type index next)) (when (eq key (aref table (* 2 next))) ;; Empty out Key and Value by using the empty value ;; in kv_vector[1]. (setf (aref table (* 2 next)) empty) (setf (aref table (1+ (* 2 next))) empty) ;; Update the prior pointer in the chain to skip this. (setf (aref next-vector prior) (aref next-vector next)) ;; Push KV slot onto free chain. (setf (aref next-vector next) (hash-table-next-free-kv hash-table)) (setf (hash-table-next-free-kv hash-table) next) (when hash-vector (setf (aref hash-vector next) +eq-based-hash-value+)) (decf (hash-table-number-entries hash-table)) (return t)))) (t ;; Not EQ based (do ((prior next next) (next (aref next-vector next) (aref next-vector next))) ((zerop next) nil) (declare (type index next)) (when (and (= hashing (aref hash-vector next)) (funcall test-fun key (aref table (* 2 next)))) ;; Empty out Key and Value by using the empty value ;; in kv_vector[1]. (setf (aref table (* 2 next)) empty) (setf (aref table (1+ (* 2 next))) empty) ;; Update the prior pointer in the chain to skip this. (setf (aref next-vector prior) (aref next-vector next)) ;; Push KV slot onto free chain. (setf (aref next-vector next) (hash-table-next-free-kv hash-table)) (setf (hash-table-next-free-kv hash-table) next) (when hash-vector (setf (aref hash-vector next) +eq-based-hash-value+)) (decf (hash-table-number-entries hash-table)) (return t))))))))) ;;; CLRHASH -- public. ;;; (defun clrhash (hash-table) "This removes all the entries from HASH-TABLE and returns the hash table itself." (let* ((kv-vector (hash-table-table hash-table)) (kv-length (length kv-vector)) (next-vector (hash-table-next-vector hash-table)) (hash-vector (hash-table-hash-vector hash-table)) (size (length next-vector)) (index-vector (hash-table-index-vector hash-table)) (length (length index-vector))) ;; Disable GC tricks. (set-header-data kv-vector vm:vector-normal-subtype) ;; Empty out the Keys and Values by using the empty value in ;; kv_vector[1]. (do ((i 2 (1+ i)) (empty (aref kv-vector 1))) ((>= i kv-length)) (setf (aref kv-vector i) empty)) (assert (eq (aref kv-vector 0) hash-table)) ;; Setup the free list, all free. (do ((i 1 (1+ i))) ((>= i (1- size))) (setf (aref next-vector i) (1+ i))) (setf (aref next-vector (1- size)) 0) (setf (hash-table-next-free-kv hash-table) 1) (setf (hash-table-needing-rehash hash-table) 0) ;; Clear the index-vector (dotimes (i length) (setf (aref index-vector i) 0)) ;; Clear the hash-vector (when hash-vector (dotimes (i size) (setf (aref hash-vector i) +eq-based-hash-value+)))) (setf (hash-table-number-entries hash-table) 0) hash-table) ;;; CLOBBER-HASH -- public. ;;; (defun clobber-hash (hash-table) "This removes all the entries from HASH-TABLE and returns the hash table itself, shrinking the size to free memory." (let* ((old-kv-vector (hash-table-table hash-table)) (old-index-vector (hash-table-index-vector hash-table)) (old-next-vector (hash-table-next-vector hash-table)) (old-hash-vector (hash-table-hash-vector hash-table)) (new-size 37) (new-kv-vector (make-array (* 2 new-size) :initial-element 'empty-hash-entry)) (new-next-vector (make-array new-size :element-type '(unsigned-byte 32) :initial-element 0)) (new-hash-vector (when old-hash-vector (make-array new-size :element-type '(unsigned-byte 32) :initial-element +eq-based-hash-value+))) (new-length 37) (new-index-vector (make-array new-length :element-type '(unsigned-byte 32) :initial-element 0))) (declare (type index new-size new-length)) ;; Disable GC tricks. (set-header-data old-kv-vector vm:vector-normal-subtype) ;; Setup the free list, all free. (do ((i 1 (1+ i))) ((>= i (1- new-size))) (setf (aref new-next-vector i) (1+ i))) (setf (aref new-next-vector (1- new-size)) 0) (setf (hash-table-rehash-trigger hash-table) new-size) (setf (hash-table-next-free-kv hash-table) 1) (setf (hash-table-needing-rehash hash-table) 0) (setf (hash-table-number-entries hash-table) 0) (setf (hash-table-table hash-table) new-kv-vector) (setf (hash-table-index-vector hash-table) new-index-vector) (setf (hash-table-next-vector hash-table) new-next-vector) (setf (hash-table-hash-vector hash-table) new-hash-vector) ;; Shrink the old vectors to 0 size to help the conservative GC. (setf old-kv-vector (shrink-vector old-kv-vector 0)) (setf old-index-vector (shrink-vector old-index-vector 0)) (setf old-next-vector (shrink-vector old-next-vector 0)) (when old-hash-vector (setf old-hash-vector (shrink-vector old-hash-vector 0)))) hash-table) ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR (declaim (maybe-inline maphash)) (defun maphash (map-function hash-table) "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value of the entry; returns NIL." (declare (type (or function symbol) map-function) (type hash-table hash-table)) (let ((fun (etypecase map-function (function map-function) (symbol (symbol-function map-function)))) (size (length (hash-table-next-vector hash-table)))) (declare (type function fun)) (do ((i 1 (1+ i)) (empty (aref (hash-table-table hash-table) 1))) ((>= i size)) (declare (type index i)) ;; Need to grab the kv-vector on each iteration in case it was ;; rehashed by a PUTHASH (let* ((kv-vector (hash-table-table hash-table)) (key (aref kv-vector (* 2 i))) (value (aref kv-vector (1+ (* 2 i))))) (unless (and (eq key empty) (eq value empty)) (funcall fun key value)))))) (defmacro with-hash-table-iterator ((function hash-table) &body body) "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) provides a method of manually looping over the elements of a hash-table. FUNCTION is bound to a generator-macro that, within the scope of the invocation, returns one or three values. The first value tells whether any objects remain in the hash table. When the first value is non-NIL, the second and third values are the key and the value of the next object." (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-"))) `(let ((,n-function (let* ((table ,hash-table) (length (length (hash-table-next-vector table))) (index 1)) (declare (type (integer 0 #.(1- (floor most-positive-fixnum 2))) index)) (labels ((,function () ;; Grab the table again on each iteration just ;; in case it was rehashed by a PUTHASH. (let ((kv-vector (hash-table-table table))) (do ((empty (aref kv-vector 1))) ((>= index length) (values nil)) (let ((key (aref kv-vector (* 2 index))) (value (aref kv-vector (1+ (* 2 index))))) (incf index) (unless (and (eq key empty) (eq value empty)) (return (values t key value)))))))) #',function)))) (macrolet ((,function () '(funcall ,n-function))) ,@body)))) ;;;; SXHASH and support functions ;;; The maximum length and depth to which we hash lists. (defconstant sxhash-max-len 7) (defconstant sxhash-max-depth 3) (eval-when (compile eval) (defconstant sxhash-bits-byte (byte 29 0)) (defconstant sxmash-total-bits 29) (defconstant sxmash-rotate-bits 9) (defmacro sxmash (place with) `(setf ,place (logxor (truly-the hash (ash ,place ,(- sxmash-rotate-bits sxmash-total-bits))) (truly-the hash (ash (logand ,place ,(1- (ash 1 (- sxmash-total-bits sxmash-rotate-bits)))) ,sxmash-rotate-bits)) (truly-the hash ,with)))) (defmacro sxhash-simple-string (sequence) `(%sxhash-simple-string ,sequence)) (defmacro sxhash-string (sequence) (let ((data (gensym)) (start (gensym)) (end (gensym)) (fill-end (gensym))) (once-only ((n-sequence sequence)) `(let ((,fill-end (if (array-has-fill-pointer-p ,n-sequence) (fill-pointer ,n-sequence) nil))) (with-array-data ((,data (the (values string &rest t) ,n-sequence)) (,start) (,end ,fill-end)) (if (zerop ,start) (%sxhash-simple-substring ,data ,end) (sxhash-simple-string (coerce (the (values string &rest t) ,n-sequence) 'simple-string)))))))) (defmacro sxhash-list (sequence depth &key (equalp nil)) `(if (= ,depth sxhash-max-depth) 0 (do ((sequence ,sequence (cdr (the list sequence))) (index 0 (1+ index)) (hash 2) (,depth (1+ ,depth))) ((or (atom sequence) (= index sxhash-max-len)) hash) (declare (fixnum hash index)) (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash) (car sequence) ,depth))))) (defmacro sxhash-bit-vector (vector) `(let* ((length (length ,vector)) (hash length)) (declare (type index length) (type hash hash)) (dotimes (index (min length sxhash-max-len) hash) (declare (type index index)) (sxmash hash (bit ,vector index))))) ); eval-when (compile eval) ;; Taken from pcl/low.lisp, and manually macroexpanded. This needs to ;; be here so we can cross-compile. (Due to tracing using an equal ;; table now.) (defun sxhash-instance (instance) (cond ((%instancep instance) (%instance-ref instance 2)) ((funcallable-instance-p instance) (%funcallable-instance-info instance 2)) (t (error (intl:gettext "What kind of instance is this?"))))) ;; End pcl/low.lisp (defun internal-sxhash (s-expr depth) (declare (type index depth) (values hash)) (typecase s-expr ;; The pointers and immediate types. (cons (sxhash-list s-expr depth)) (fixnum (ldb sxhash-bits-byte s-expr)) (character (char-code s-expr)) (pathname ;; Pathnames are EQUAL if all the components are EQUAL, so we ;; hash all of the components of a pathname together. (let ((hash (internal-sxhash (%pathname-host s-expr) depth))) (sxmash hash (internal-sxhash (%pathname-device s-expr) depth)) (sxmash hash (internal-sxhash (%pathname-directory s-expr) depth)) (sxmash hash (internal-sxhash (%pathname-name s-expr) depth)) (sxmash hash (internal-sxhash (%pathname-type s-expr) depth)) ;; Hash :newest the same as NIL because EQUAL for pathnames ;; assumes that :newest and nil are equal. (let ((version (%pathname-version s-expr))) (sxmash hash (internal-sxhash (if (eql version :newest) nil version) depth))))) (instance (if (or (typep s-expr 'structure-object) (typep s-expr 'condition)) (internal-sxhash (%class-name (layout-class (%instance-layout s-expr))) depth) (sxhash-instance s-expr))) (funcallable-instance (if (eval:interpreted-function-p s-expr) (internal-sxhash (eval:interpreted-function-lambda-expression s-expr) depth) (sxhash-instance s-expr))) ;; Other-pointer types. (simple-string (sxhash-simple-string s-expr)) (symbol #-(or sparc x86 ppc) (sxhash-simple-string (symbol-name s-expr)) #+(or sparc x86 ppc) (sxhash s-expr)) (number (etypecase s-expr (integer (ldb sxhash-bits-byte s-expr)) (single-float ;; CLHS says sxhash must return the same thing for +0.0 and ;; -0.0. We get the desired result by adding +0.0, which ;; converts -0.0 to 0.0. But if s-expr is NaN, we don't want ;; to signal an error from adding 0, so don't do it since it ;; we don't need to anyway. (let* ((x (if (float-nan-p s-expr) s-expr (+ s-expr 0f0))) (bits (single-float-bits x))) (ldb sxhash-bits-byte (logxor (ash bits (- sxmash-rotate-bits)) bits)))) (double-float (let* ((x (if (float-nan-p s-expr) s-expr (+ s-expr 0d0))) (lo (double-float-low-bits x)) (hi (double-float-high-bits x))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo (ldb sxhash-bits-byte (logxor (ash hi (- sxmash-rotate-bits)) hi)))))) #+long-float (long-float (let ((lo (long-float-low-bits s-expr)) #+sparc (mid (long-float-mid-bits s-expr)) (hi (long-float-high-bits s-expr)) (exp (long-float-exp-bits s-expr))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid (ash hi (- sxmash-rotate-bits)) hi (ldb sxhash-bits-byte (logxor (ash exp (- sxmash-rotate-bits)) exp)))))) #+double-double (double-double-float ;; Is this good enough? (logxor (internal-sxhash (kernel:double-double-hi s-expr) depth) (internal-sxhash (kernel:double-double-lo s-expr) depth))) (ratio (logxor (internal-sxhash (numerator s-expr) 0) (internal-sxhash (denominator s-expr) 0))) (complex (logxor (internal-sxhash (realpart s-expr) 0) (internal-sxhash (imagpart s-expr) 0))))) (array (typecase s-expr (string (sxhash-string s-expr)) (simple-bit-vector (sxhash-bit-vector (truly-the simple-bit-vector s-expr))) (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr))) (t (array-rank s-expr)))) ;; Everything else. (t 42))) (defun sxhash (s-expr) "Computes a hash code for S-EXPR and returns it as an integer." (internal-sxhash s-expr 0)) ;;;; Equalp hash. (eval-when (compile eval) (defmacro hash-table-equalp-hash (table) `(let ((hash (hash-table-count ,table))) (declare (type hash hash)) (sxmash hash (sxhash (hash-table-test ,table))) hash)) (defmacro structure-equalp-hash (structure depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((layout (%instance-layout ,structure)) (length (min (1- (layout-length layout)) sxhash-max-len)) (hash (internal-sxhash (%class-name (layout-class layout)) depth)) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) (do ((index 1 (1+ index))) ((= index length) hash) (declare (type index index)) (sxmash hash (internal-equalp-hash (%instance-ref ,structure index) ,depth)))))) (defmacro vector-equalp-hash (vector depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((length (length ,vector)) (hash length) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) (dotimes (index (min length sxhash-max-len) hash) (declare (type index index)) (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth)))))) (defmacro array-equalp-hash (array depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((size (array-total-size ,array)) (hash size) (,depth (+ ,depth 1))) (declare (type hash hash)) (dotimes (index (min sxhash-max-len size) hash) (sxmash hash (internal-equalp-hash (row-major-aref ,array index) ,depth)))))) ); eval-when (compile eval) (defun internal-equalp-hash (s-expr depth) (declare (type index depth) (values hash)) (typecase s-expr ;; The pointers and immediate types. (cons (sxhash-list s-expr depth :equalp t)) (fixnum (ldb sxhash-bits-byte s-expr)) (character (char-code (char-upcase s-expr))) (instance (typecase s-expr (hash-table (hash-table-equalp-hash s-expr)) (structure-object (structure-equalp-hash s-expr depth)) (t 42))) ;; Other-pointer types. (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth)) (symbol (sxhash-simple-string (symbol-name s-expr))) (number (etypecase s-expr (integer (sxhash s-expr)) (float (macrolet ((frob (val type) (let ((lo (coerce most-negative-fixnum type)) (hi (coerce most-positive-fixnum type))) `(if (<= ,lo ,val ,hi) (multiple-value-bind (q r) (truncate ,val) (if (zerop r) (sxhash q) (sxhash (coerce ,val 'long-float)))) (multiple-value-bind (q r) (truncate ,val) (if (zerop r) (sxhash q) (sxhash (coerce ,val 'long-float)))))))) (etypecase s-expr (single-float (frob s-expr single-float)) (double-float (frob s-expr double-float)) #+long-float (long-float (frob s-expr long-float))))) (ratio (let ((float (coerce s-expr 'long-float))) (if (= float s-expr) (sxhash float) (sxhash s-expr)))) (complex (if (zerop (imagpart s-expr)) (internal-equalp-hash (realpart s-expr) 0) (logxor (internal-equalp-hash (realpart s-expr) 0) (internal-equalp-hash (realpart s-expr) 0)))))) (array (typecase s-expr (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth)) (vector (vector-equalp-hash s-expr depth)) (t (array-equalp-hash s-expr depth)))) ;; Everything else. (t 42))) ;;;; Dumping one as a constant. (defun make-hash-table-load-form (table) (values `(make-hash-table :test ',(hash-table-test table) :size ',(hash-table-size table) :rehash-size ',(hash-table-rehash-size table) :rehash-threshold ',(hash-table-rehash-threshold table) :weak-p ,(hash-table-weak-p table)) (let ((values nil)) (declare (inline maphash)) (maphash #'(lambda (key value) (push (cons key value) values)) table) (if values `(stuff-hash-table ,table ',values) nil)))) (defun stuff-hash-table (table alist) (dolist (x alist) (setf (gethash (car x) table) (cdr x)))) cmucl-21a/src/code/hash.lisp000066400000000000000000001054711260377556400161060ustar00rootroot00000000000000;;; -*- Package: CL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/hash.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Hashing and hash table functions for Spice Lisp. ;;; Originally written by Skef Wholey. ;;; Everything except SXHASH rewritten by William Lott. ;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000. ;;; (in-package :lisp) (intl:textdomain "cmucl") (export '(hash-table hash-table-p make-hash-table gethash remhash maphash clrhash hash-table-count with-hash-table-iterator hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test sxhash)) (in-package :ext) (export '(define-hash-table-test)) (in-package :lisp) ;;;; The hash-table structures. ;;; HASH-TABLE -- defstruct. ;;; (defstruct (hash-table (:constructor %make-hash-table) (:print-function %print-hash-table) (:make-load-form-fun make-hash-table-load-form)) "Structure used to implement hash tables." ;; ;; The type of hash table this is. Only used for printing and as part of ;; the exported interface. (test (required-argument) :type symbol :read-only t) ;; ;; The function used to compare two keys. Returns T if they are the same ;; and NIL if not. (test-fun (required-argument) :type function :read-only t) ;; ;; The function used to compute the hashing of a key. Returns two values: ;; the index hashing and T if that might change with the next GC. (hash-fun (required-argument) :type function :read-only t) ;; ;; How much to grow the hash table by when it fills up. If an index, then ;; add that amount. If a floating point number, then multiply it by that. (rehash-size (required-argument) :type (or index (single-float (1.0))) :read-only t) ;; ;; How full the hash table has to get before we rehash. (rehash-threshold (required-argument) :type (single-float (0.0) 1.0) :read-only t) ;; ;; (* rehash-threshold (length table)), saved here so we don't have to keep ;; recomputing it. (rehash-trigger (required-argument) :type index) ;; ;; The current number of entries in the table. (number-entries 0 :type index) ;; ;; Vector of ht-buckets. (table (required-argument) :type simple-vector) ;; ;; True if this is a weak hash table, meaning that key->value mappings will ;; disappear if there are no other references to the key. Note: this only ;; matters if the hash function indicates that the hashing is EQ based. (weak-p nil :type (member t nil)) ;; #+gengc ;; Chain of buckets that need to be rehashed because their hashing is EQ ;; based and the key has been moved by the garbage collector. (needing-rehash nil :type (or null hash-table-bucket))) ;;; (defun %print-hash-table (ht stream depth) (declare (ignore depth) (stream stream)) (print-unreadable-object (ht stream :identity t) (format stream "~A hash table, ~D entr~@:P" (symbol-name (hash-table-test ht)) (hash-table-number-entries ht)))) (defconstant max-hash most-positive-fixnum) (deftype hash () `(integer 0 ,max-hash)) (defstruct (hash-table-bucket (:print-function %print-hash-table-bucket)) ;; ;; The hashing associated with key, kept around so we don't have to recompute ;; it each time. In the non-gengc system, if this is NIL it means that the ;; hashing is EQ based, so use the address of the value. If the gengc ;; system, we use the presence of the scavhook to tell that. #-gengc (hash nil :type (or hash null)) #+gengc (hash 0 :type hash) ;; ;; The key and value, originally supplied by the user. If the hash table ;; is weak, and this is eq based, then the key is really a weak pointer to ;; the key. (key nil :type t) (value nil :type t) ;; ;; The next bucket, or NIL if there are no more. (next nil :type (or hash-table-bucket null))) ;;; (defun %print-hash-table-bucket (bucket stream depth) (declare (ignore depth)) (print-unreadable-object (bucket stream :type t) (format stream "for ~S->~S~@[ ~D~]" (hash-table-bucket-key bucket) (hash-table-bucket-value bucket) (hash-table-bucket-hash bucket)))) #+gengc (defstruct (hash-table-eq-bucket (:include hash-table-bucket)) ;; ;; The scavenger-hook object used to detect when the EQ hashing of key will ;; change. Only NIL during creation. (scavhook nil :type (or null scavenger-hook)) ;; ;; True iff this bucket is still linked into the corresponding hash table's ;; vector. (linked nil :type (member t nil))) #| ;;; SCAN-STATE -- defstruct. ;;; ;;; Holds the state of a MAPHASH or WITH-HASH-TABLE-ITERATOR. ;;; (defstruct (scan-state) ;; ;; The index into the hash-table-table. (index 0 :type index) ;; ;; The current bucket in that chain. (bucket nil :type (or null hash-table-bucket)) ;; ) ;;; Non-gengc: ;;; ;;; %puthash: if there are any active scans, then make sure the current bucket ;;; for each scan holds the key we are trying to puthash, and flame out of it ;;; isn't. Given that we have our hands directly on the correct bucket, just ;;; go for it. ;;; ;;; remhash: make the same check as with %puthash. If it checks out, then ;;; just scan down the correct bucket chain and yank it. ;;; ;;; rehash: because of the above two tests, rehash will only be called by ;;; gethash. And we need to do the rehash in order to look anything up. So ;;; make a list of all the remaining buckets, and stick them in the scan-state. ;;; ;;; Gengc: ;;; ;;; %puthash & remhash: same as above. ;;; ;;; rehash: is only ever called by puthash, so doesn't need anything special to ;;; account for active scans. ;;; ;;; flush-needing-rehash: will only be called by gethash for the same reason ;;; rehash is only called by gethash in the non-gengc system. And basically ;;; needs to do the same thing rehash does in the non-gengc system. ;;; ;;; hash-table-scavenger-hook: needs to check to see if the bucket being ;;; unlinked is after the current bucket in any of the active scans. If so, ;;; it needs to add it to a list of buckets that will be processed after all ;;; the buckets visable in the hash-table-table have been delt with. |# ;;;; Utility functions. (declaim (inline pointer-hash)) (defun pointer-hash (key) (declare (values hash)) (truly-the hash (%primitive make-fixnum key))) (declaim (inline eq-hash)) (defun eq-hash (key) (declare (values hash (member t nil))) (values (pointer-hash key) (oddp (get-lisp-obj-address key)))) (declaim (inline eql-hash)) (defun eql-hash (key) (declare (values hash (member t nil))) (if (numberp key) (equal-hash key) (eq-hash key))) (declaim (inline equal-hash)) (defun equal-hash (key) (declare (values hash (member t nil))) (values (sxhash key) nil)) (defun equalp-hash (key) (declare (values hash (member t nil))) (values (internal-equalp-hash key 0) nil)) (defun almost-primify (num) (declare (type index num)) "Almost-Primify returns an almost prime number greater than or equal to NUM." (if (= (rem num 2) 0) (setq num (+ 1 num))) (if (= (rem num 3) 0) (setq num (+ 2 num))) (if (= (rem num 7) 0) (setq num (+ 4 num))) num) ;;;; User defined hash table tests. ;;; *HASH-TABLE-TESTS* -- Internal. ;;; (defvar *hash-table-tests* nil) ;;; DEFINE-HASH-TABLE-TEST -- Public. ;;; (defun define-hash-table-test (name test-fun hash-fun) "Define a new kind of hash table test." (declare (type symbol name) (type function test-fun hash-fun)) (setf *hash-table-tests* (cons (list name test-fun hash-fun) (remove name *hash-table-tests* :test #'eq :key #'car))) name) ;;;; Construction and simple accessors. ;;; MAKE-HASH-TABLE -- public. ;;; (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5) (rehash-threshold 1) (weak-p nil)) "Creates and returns a new hash table. The keywords are as follows: :TEST -- Indicates what kind of test to use. Only EQ, EQL, EQUAL, and EQUALP are currently supported. :SIZE -- A hint as to how many elements will be put in this hash table. :REHASH-SIZE -- Indicates how to expand the table when it fills up. If an integer, add space for that many elements. If a floating point number (which must be greater than 1.0), multiple the size by that amount. :REHASH-THRESHOLD -- Indicates how dense the table can become before forcing a rehash. Can be any positive number <= to 1, with density approaching zero as the threshold approaches 0. Density 1 means an average of one entry per bucket. CMUCL Extension: :WEAK-P -- If T, don't keep entries if the key would otherwise be garbage." (declare (type (or function symbol) test) (type index size) (type (member t nil) weak-p)) (let ((rehash-size (if (integerp rehash-size) rehash-size (float rehash-size 1.0))) (rehash-threshold (float rehash-threshold 1.0))) (multiple-value-bind (test test-fun hash-fun) (cond ((or (eq test #'eq) (eq test 'eq)) (values 'eq #'eq #'eq-hash)) ((or (eq test #'eql) (eq test 'eql)) (values 'eql #'eql #'eql-hash)) ((or (eq test #'equal) (eq test 'equal)) (values 'equal #'equal #'equal-hash)) ((or (eq test #'equalp) (eq test 'equalp)) (values 'equalp #'equalp #'equalp-hash)) (t (dolist (info *hash-table-tests* (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" test)) (destructuring-bind (test-name test-fun hash-fun) info (when (or (eq test test-name) (eq test test-fun)) (return (values test-name test-fun hash-fun))))))) (let* ((scaled-size (round (/ (float size) rehash-threshold))) (length (if (<= scaled-size 37) 37 (almost-primify scaled-size))) (vector (make-array length :initial-element nil))) (declare (type index scaled-size length) (type simple-vector vector)) (%make-hash-table :test test :test-fun test-fun :hash-fun hash-fun :rehash-size rehash-size :rehash-threshold rehash-threshold :rehash-trigger (round (* (float length) rehash-threshold)) :table vector :weak-p weak-p))))) (declaim (inline hash-table-count)) (defun hash-table-count (hash-table) "Returns the number of entries in the given HASH-TABLE." (declare (type hash-table hash-table) (values index)) (hash-table-number-entries hash-table)) (setf (documentation 'hash-table-rehash-size 'function) "Return the rehash-size HASH-TABLE was created with.") (setf (documentation 'hash-table-rehash-threshold 'function) "Return the rehash-threshold HASH-TABLE was created with.") (declaim (inline hash-table-size)) (defun hash-table-size (hash-table) "Return a size that can be used with MAKE-HASH-TABLE to create a hash table that can hold however many entries HASH-TABLE can hold without having to be grown." (hash-table-rehash-trigger hash-table)) (setf (documentation 'hash-table-test 'function) "Return the test HASH-TABLE was created with.") (setf (documentation 'hash-table-weak-p 'function) "Return T if HASH-TABLE will not keep entries for keys that would otherwise be garbage, and NIL if it will.") ;;;; Accessing functions. ;;; REHASH -- internal. ;;; ;;; Make a new vector for TABLE. If GROW is NIL, use the same size as before, ;;; otherwise extend the table based on the rehash-size. ;;; (defun rehash (table grow) (declare (type hash-table table)) (let* ((old-vector (hash-table-table table)) (old-length (length old-vector)) (new-length (if grow (let ((rehash-size (hash-table-rehash-size table))) (etypecase rehash-size (fixnum (+ rehash-size old-length)) (float (the (values index t) (round (* rehash-size old-length)))))) old-length)) (new-vector (make-array new-length :initial-element nil)) #-gengc (weak-p (hash-table-weak-p table))) (declare (type index new-length)) (dotimes (i old-length) (declare (type index i)) (do ((bucket (svref old-vector i) next) (next nil)) ((null bucket)) (setf next (hash-table-bucket-next bucket)) (block deal-with-one-bucket (let* ((hashing #-gengc (or (hash-table-bucket-hash bucket) (let ((key (hash-table-bucket-key bucket))) (set-header-data new-vector vm:vector-valid-hashing-subtype) (if weak-p (multiple-value-bind (real-key valid) (weak-pointer-value key) (cond (valid (pointer-hash real-key)) (t (decf (hash-table-number-entries table)) (return-from deal-with-one-bucket nil)))) (pointer-hash key)))) #+gengc (hash-table-bucket-hash bucket)) (index (rem hashing new-length))) (declare (type index hashing index)) (setf (hash-table-bucket-next bucket) (svref new-vector index)) (setf (svref new-vector index) bucket)))) ;; We clobber the old vector contents so that if it is living in ;; static space it won't keep ahold of pointers into dynamic space. (setf (svref old-vector i) nil)) (setf (hash-table-table table) new-vector) (unless (= new-length old-length) (setf (hash-table-rehash-trigger table) (round (* (hash-table-rehash-threshold table) (float new-length)))))) (undefined-value)) #+gengc (defun flush-needing-rehash (table) (let* ((weak-p (hash-table-weak-p table)) (vector (hash-table-table table)) (length (length vector))) (do ((bucket (hash-table-needing-rehash table) next) (next nil)) ((null bucket)) (setf next (hash-table-bucket-next bucket)) (flet ((relink-bucket (key) (let* ((hashing (pointer-hash key)) (index (rem hashing length))) (setf (hash-table-bucket-hash bucket) hashing) (setf (hash-table-bucket-next bucket) (svref vector index)) (setf (svref vector index) bucket) (setf (hash-table-eq-bucket-linked bucket) t)))) (let ((key (hash-table-bucket-key bucket))) (if weak-p (multiple-value-bind (real-key valid) (weak-pointer-value key) (if valid (relink-bucket real-key) (decf (hash-table-number-entries table)))) (relink-bucket key)))))) (setf (hash-table-needing-rehash table) nil) (undefined-value)) ;;; GETHASH -- Public. ;;; (defun gethash (key hash-table &optional default) "Finds the entry in HASH-TABLE whose key is KEY and returns the associated value and T as multiple values, or returns DEFAULT and NIL if there is no such entry. Entries can be added using SETF." (declare (type hash-table hash-table) (values t (member t nil))) (without-gcing #-gengc (when (= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)) #+gengc (when (hash-table-needing-rehash hash-table) (flush-needing-rehash hash-table)) (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (let* ((vector (hash-table-table hash-table)) (length (length vector)) (index (rem hashing length))) (declare (type index hashing)) (if eq-based (if (hash-table-weak-p hash-table) (do ((bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) (values default nil)) (when #+gengc (hash-table-eq-bucket-p bucket) #-gengc (null (hash-table-bucket-hash bucket)) (multiple-value-bind (bucket-key valid) (weak-pointer-value (hash-table-bucket-key bucket)) (assert valid) (when (eq key bucket-key) (return (values (hash-table-bucket-value bucket) t)))))) (do ((bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) (values default nil)) (when (eq key (hash-table-bucket-key bucket)) (return (values (hash-table-bucket-value bucket) t))))) (do ((test-fun (hash-table-test-fun hash-table)) (bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) (values default nil)) (let ((bucket-hashing (hash-table-bucket-hash bucket))) (when (and #-gengc bucket-hashing (= bucket-hashing hashing) #+gengc (not (hash-table-eq-bucket-p bucket)) (funcall test-fun key (hash-table-bucket-key bucket))) (return (values (hash-table-bucket-value bucket) t)))))))))) #+gengc (defun get-hash-table-scavenger-hook (hash-table bucket) (declare (type hash-table hash-table) (type hash-table-eq-bucket bucket)) (flet ((hash-table-scavenger-hook () (when (hash-table-eq-bucket-linked bucket) (let* ((vector (hash-table-table hash-table)) (length (length vector)) (index (rem (hash-table-eq-bucket-hash bucket) length))) (declare (type index index)) (do ((prev nil next) (next (svref vector index) (hash-table-bucket-next next))) ((null next) (warn "Couldn't find where ~S was linked inside ~S" bucket hash-table)) (when (eq next bucket) (if prev (setf (hash-table-bucket-next prev) (hash-table-bucket-next bucket)) (setf (svref vector index) (hash-table-bucket-next bucket))) (setf (hash-table-eq-bucket-linked bucket) nil) (return))) (if (and (hash-table-weak-p hash-table) (not (nth-value 1 (weak-pointer-value (hash-table-bucket-key bucket))))) (decf (hash-table-number-entries hash-table)) (setf (hash-table-bucket-next bucket) (hash-table-needing-rehash hash-table) (hash-table-needing-rehash hash-table) bucket)))))) #'hash-table-scavenger-hook)) ;;; So people can call #'(setf gethash). ;;; (defun (setf gethash) (new-value key table &optional default) (declare (ignore default)) (%puthash key table new-value)) ;;; %PUTHASH -- public setf method. ;;; (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) (without-gcing (let ((entries (1+ (hash-table-number-entries hash-table)))) (setf (hash-table-number-entries hash-table) entries) (cond ((> entries (hash-table-rehash-trigger hash-table)) (rehash hash-table t)) #-gengc ((= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)))) #+gengc (when (hash-table-needing-rehash hash-table) (flush-needing-rehash hash-table)) (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((vector (hash-table-table hash-table)) (length (length vector)) (index (rem hashing length)) (first-bucket (svref vector index))) (declare (type index index)) (block scan (if eq-based (if (hash-table-weak-p hash-table) (do ((bucket first-bucket (hash-table-bucket-next bucket))) ((null bucket)) (when #+gengc (hash-table-eq-bucket-p bucket) #-gengc (null (hash-table-bucket-hash bucket)) (multiple-value-bind (bucket-key valid) (weak-pointer-value (hash-table-bucket-key bucket)) (assert valid) (when (eq key bucket-key) (setf (hash-table-bucket-value bucket) value) (decf (hash-table-number-entries hash-table)) (return-from scan nil))))) (do ((bucket first-bucket (hash-table-bucket-next bucket))) ((null bucket)) (when (eq key (hash-table-bucket-key bucket)) (setf (hash-table-bucket-value bucket) value) (decf (hash-table-number-entries hash-table)) (return-from scan nil)))) (do ((test-fun (hash-table-test-fun hash-table)) (bucket first-bucket (hash-table-bucket-next bucket))) ((null bucket)) (let ((bucket-hashing (hash-table-bucket-hash bucket))) (when (and #-gengc bucket-hashing (= bucket-hashing hashing) #+gengc (not (hash-table-eq-bucket-p bucket)) (funcall test-fun key (hash-table-bucket-key bucket))) (setf (hash-table-bucket-value bucket) value) (decf (hash-table-number-entries hash-table)) (return-from scan nil))))) #-gengc (when eq-based (set-header-data vector vm:vector-valid-hashing-subtype)) (setf (svref vector index) #-gengc (if eq-based (make-hash-table-bucket :hash nil :key (if (hash-table-weak-p hash-table) (make-weak-pointer key) key) :value value :next first-bucket) (make-hash-table-bucket :hash hashing :key key :value value :next first-bucket)) #+gengc (if eq-based (let ((bucket (make-hash-table-eq-bucket :hash hashing :key (if (hash-table-weak-p hash-table) (make-weak-pointer key) key) :value value :next first-bucket :linked t))) (setf (hash-table-eq-bucket-scavhook bucket) (make-scavenger-hook :value key :function (get-hash-table-scavenger-hook hash-table bucket))) bucket) (make-hash-table-bucket :hash hashing :key key :value value :next first-bucket))))))) value) ;;; REMHASH -- public. ;;; (defun remhash (key hash-table) "Remove the entry in HASH-TABLE associated with KEY. Returns T if there was such an entry, and NIL if not." (declare (type hash-table hash-table) (values (member t nil))) (without-gcing #-gengc (when (= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)) #+gengc (when (hash-table-needing-rehash hash-table) (flush-needing-rehash hash-table)) (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (let* ((vector (hash-table-table hash-table)) (length (length vector)) (index (rem hashing length))) (declare (type index hashing index)) (if eq-based (if (hash-table-weak-p hash-table) (do ((prev nil bucket) (bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) nil) (when #+gengc (hash-table-eq-bucket-p bucket) #-gengc (null (hash-table-bucket-hash bucket)) (multiple-value-bind (bucket-key valid) (weak-pointer-value (hash-table-bucket-key bucket)) (assert valid) (when (eq key bucket-key) #+gengc (setf (hash-table-eq-bucket-linked bucket) nil) (if prev (setf (hash-table-bucket-next prev) (hash-table-bucket-next bucket)) (setf (svref vector index) (hash-table-bucket-next bucket))) (decf (hash-table-number-entries hash-table)) (return t))))) (do ((prev nil bucket) (bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) nil) (when (eq key (hash-table-bucket-key bucket)) #+gengc (setf (hash-table-eq-bucket-linked bucket) nil) (if prev (setf (hash-table-bucket-next prev) (hash-table-bucket-next bucket)) (setf (svref vector index) (hash-table-bucket-next bucket))) (decf (hash-table-number-entries hash-table)) (return t)))) (do ((test-fun (hash-table-test-fun hash-table)) (prev nil bucket) (bucket (svref vector index) (hash-table-bucket-next bucket))) ((null bucket) nil) (let ((bucket-hashing (hash-table-bucket-hash bucket))) (when (and #-gengc bucket-hashing (= bucket-hashing hashing) #+gengc (not (hash-table-eq-bucket-p bucket)) (funcall test-fun key (hash-table-bucket-key bucket))) (if prev (setf (hash-table-bucket-next prev) (hash-table-bucket-next bucket)) (setf (svref vector index) (hash-table-bucket-next bucket))) (decf (hash-table-number-entries hash-table)) (return t))))))))) ;;; CLRHASH -- public. ;;; (defun clrhash (hash-table) "This removes all the entries from HASH-TABLE and returns the hash table itself." (let ((vector (hash-table-table hash-table))) (dotimes (i (length vector)) #+gengc (do ((bucket (aref vector i) (hash-table-bucket-next bucket))) ((null bucket)) (when (hash-table-eq-bucket-p bucket) (setf (hash-table-eq-bucket-linked bucket) nil))) (setf (aref vector i) nil)) (setf (hash-table-number-entries hash-table) 0) #-gengc (set-header-data vector vm:vector-normal-subtype)) hash-table) ;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR (declaim (maybe-inline maphash)) (defun maphash (map-function hash-table) "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value of the entry; returns NIL." (declare (type (or function symbol) map-function) (type hash-table hash-table)) (let ((fun (etypecase map-function (function map-function) (symbol (symbol-function map-function)))) (vector (hash-table-table hash-table))) (declare (type function fun)) (if (hash-table-weak-p hash-table) (dotimes (i (length vector)) (declare (type index i)) (do ((bucket (svref vector i) (hash-table-bucket-next bucket))) ((null bucket)) (if #-gengc (null (hash-table-bucket-hash bucket)) #+gengc (hash-table-eq-bucket-p bucket) (let ((weak-pointer (hash-table-bucket-key bucket))) (multiple-value-bind (key valid) (weak-pointer-value weak-pointer) (when valid (funcall fun key (hash-table-bucket-value bucket))))) (funcall fun (hash-table-bucket-key bucket) (hash-table-bucket-value bucket))))) (dotimes (i (length vector)) (declare (type index i)) (do ((bucket (svref vector i) (hash-table-bucket-next bucket))) ((null bucket)) (funcall fun (hash-table-bucket-key bucket) (hash-table-bucket-value bucket))))))) (defmacro with-hash-table-iterator ((function hash-table) &body body) "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) provides a method of manually looping over the elements of a hash-table. function is bound to a generator-macro that, withing the scope of the invocation, returns three values. First, whether there are any more objects in the hash-table, second, the key, and third, the value." (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-"))) `(let ((,n-function (let* ((table ,hash-table) (weak-p (hash-table-weak-p ,hash-table)) (vector (hash-table-table table)) (length (length vector)) (index 0) (bucket (svref vector 0))) (labels ((,function () (cond (bucket (let ((orig bucket)) (setf bucket (hash-table-bucket-next orig)) (if (and weak-p #-gengc (null (hash-table-bucket-hash orig)) #+gengc (hash-table-eq-bucket-p orig)) (multiple-value-bind (key valid) (weak-pointer-value (hash-table-bucket-key orig)) (if valid (values t key (hash-table-bucket-value orig)) (,function))) (values t (hash-table-bucket-key orig) (hash-table-bucket-value orig))))) ((= (incf index) length) (values nil)) (t (setf bucket (svref vector index)) (,function))))) #',function)))) (macrolet ((,function () '(funcall ,n-function))) ,@body)))) ;;;; SXHASH and support functions ;;; The maximum length and depth to which we hash lists. (defconstant sxhash-max-len 7) (defconstant sxhash-max-depth 3) (eval-when (compile eval) (defconstant sxhash-bits-byte (byte 29 0)) (defconstant sxmash-total-bits 29) (defconstant sxmash-rotate-bits 9) (defmacro sxmash (place with) `(setf ,place (logxor (truly-the hash (ash ,place ,(- sxmash-rotate-bits sxmash-total-bits))) (truly-the hash (ash (logand ,place ,(1- (ash 1 (- sxmash-total-bits sxmash-rotate-bits)))) ,sxmash-rotate-bits)) (truly-the hash ,with)))) (defmacro sxhash-simple-string (sequence) `(%sxhash-simple-string ,sequence)) (defmacro sxhash-string (sequence) (let ((data (gensym)) (start (gensym)) (end (gensym))) `(with-array-data ((,data (the (values string &rest t) ,sequence)) (,start) (,end)) (if (zerop ,start) (%sxhash-simple-substring ,data ,end) (sxhash-simple-string (coerce (the (values string &rest t) ,sequence) 'simple-string)))))) (defmacro sxhash-list (sequence depth &key (equalp nil)) `(if (= ,depth sxhash-max-depth) 0 (do ((sequence ,sequence (cdr (the list sequence))) (index 0 (1+ index)) (hash 2) (,depth (1+ ,depth))) ((or (atom sequence) (= index sxhash-max-len)) hash) (declare (fixnum hash index)) (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash) (car sequence) ,depth))))) (defmacro sxhash-bit-vector (vector) `(let* ((length (length ,vector)) (hash length)) (declare (type index length) (type hash hash)) (dotimes (index (min length sxhash-max-len) hash) (declare (type index index)) (sxmash hash (bit ,vector index))))) ); eval-when (compile eval) (defun internal-sxhash (s-expr depth) (declare (type index depth) (values hash)) (typecase s-expr ;; The pointers and immediate types. (list (sxhash-list s-expr depth)) (fixnum (ldb sxhash-bits-byte s-expr)) (character (char-code (char-upcase s-expr))) (instance (if (typep s-expr 'structure-object) (internal-sxhash (%class-name (layout-class (%instance-layout s-expr))) depth) (sxhash-instance s-expr))) (funcallable-instance (sxhash-instance s-expr)) ;; Other-pointer types. (simple-string (sxhash-simple-string s-expr)) (symbol (sxhash-simple-string (symbol-name s-expr))) (number (etypecase s-expr (integer (ldb sxhash-bits-byte s-expr)) (single-float (let ((bits (single-float-bits s-expr))) (ldb sxhash-bits-byte (logxor (ash bits (- sxmash-rotate-bits)) bits)))) (double-float (let ((lo (double-float-low-bits s-expr)) (hi (double-float-high-bits s-expr))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo (ldb sxhash-bits-byte (logxor (ash hi (- sxmash-rotate-bits)) hi)))))) #+long-float (long-float (let ((lo (long-float-low-bits s-expr)) #+sparc (mid (long-float-mid-bits s-expr)) (hi (long-float-high-bits s-expr)) (exp (long-float-exp-bits s-expr))) (ldb sxhash-bits-byte (logxor (ash lo (- sxmash-rotate-bits)) lo #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid (ash hi (- sxmash-rotate-bits)) hi (ldb sxhash-bits-byte (logxor (ash exp (- sxmash-rotate-bits)) exp)))))) (ratio (logxor (internal-sxhash (numerator s-expr) 0) (internal-sxhash (denominator s-expr) 0))) (complex (logxor (internal-sxhash (realpart s-expr) 0) (internal-sxhash (imagpart s-expr) 0))))) (array (typecase s-expr (string (sxhash-string s-expr)) (simple-bit-vector (sxhash-bit-vector (truly-the simple-bit-vector s-expr))) (bit-vector (sxhash-bit-vector (truly-the bit-vector s-expr))) (t (array-rank s-expr)))) ;; Everything else. (t 42))) (defun sxhash (s-expr) "Computes a hash code for S-EXPR and returns it as an integer." (internal-sxhash s-expr 0)) ;;;; Equalp hash. (eval-when (compile eval) (defmacro hash-table-equalp-hash (table) `(let ((hash (hash-table-count ,table))) (declare (type hash hash)) (sxmash hash (sxhash (hash-table-test ,table))) hash)) (defmacro structure-equalp-hash (structure depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((layout (%instance-layout ,structure)) (length (min (1- (layout-length layout)) sxhash-max-len)) (hash (internal-sxhash (%class-name (layout-class layout)) depth)) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) (do ((index 1 (1+ index))) ((= index length) hash) (declare (type index index)) (sxmash hash (internal-equalp-hash (%instance-ref ,structure index) ,depth)))))) (defmacro vector-equalp-hash (vector depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((length (length ,vector)) (hash length) (,depth (+ ,depth 1))) (declare (type index length) (type hash hash)) (dotimes (index (min length sxhash-max-len) hash) (declare (type index index)) (sxmash hash (internal-equalp-hash (aref ,vector index) ,depth)))))) (defmacro array-equalp-hash (array depth) `(if (= ,depth sxhash-max-depth) 0 (let* ((size (array-total-size ,array)) (hash size) (,depth (+ ,depth 1))) (declare (type hash hash)) (dotimes (index (min sxhash-max-len size) hash) (sxmash hash (internal-equalp-hash (row-major-aref ,array index) ,depth)))))) ); eval-when (compile eval) (defun internal-equalp-hash (s-expr depth) (declare (type index depth) (values hash)) (typecase s-expr ;; The pointers and immediate types. (list (sxhash-list s-expr depth :equalp t)) (fixnum (ldb sxhash-bits-byte s-expr)) (character (char-code (char-upcase s-expr))) (instance (typecase s-expr (hash-table (hash-table-equalp-hash s-expr)) (structure-object (structure-equalp-hash s-expr depth)) (t 42))) ;; Other-pointer types. (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth)) (symbol (sxhash-simple-string (symbol-name s-expr))) (number (etypecase s-expr (integer (sxhash s-expr)) (float (macrolet ((frob (val type) (let ((lo (coerce most-negative-fixnum type)) (hi (coerce most-positive-fixnum type))) `(if (<= ,lo ,val ,hi) (multiple-value-bind (q r) (truncate ,val) (if (zerop r) (sxhash q) (sxhash (coerce ,val 'long-float)))) (multiple-value-bind (q r) (truncate ,val) (if (zerop r) (sxhash q) (sxhash (coerce ,val 'long-float)))))))) (etypecase s-expr (single-float (frob s-expr single-float)) (double-float (frob s-expr double-float)) #+long-float (long-float (frob s-expr long-float))))) (ratio (let ((float (coerce s-expr 'long-float))) (if (= float s-expr) (sxhash float) (sxhash s-expr)))) (complex (if (zerop (imagpart s-expr)) (internal-equalp-hash (realpart s-expr) 0) (logxor (internal-equalp-hash (realpart s-expr) 0) (internal-equalp-hash (realpart s-expr) 0)))))) (array (typecase s-expr (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth)) (vector (vector-equalp-hash s-expr depth)) (t (array-equalp-hash s-expr depth)))) ;; Everything else. (t 42))) ;;;; Dumping one as a constant. (defun make-hash-table-load-form (table) (values `(make-hash-table :test ',(hash-table-test table) :size ',(hash-table-size table) :rehash-size ',(hash-table-rehash-size table) :rehash-threshold ',(hash-table-rehash-threshold table)) (let ((values nil)) (declare (inline maphash)) (maphash #'(lambda (key value) (push (cons key value) values)) table) (if values `(stuff-hash-table ,table ',values) nil)))) (defun stuff-hash-table (table alist) (dolist (x alist) (setf (gethash (car x) table) (cdr x)))) cmucl-21a/src/code/hppa-vm.lisp000066400000000000000000000213351260377556400165270ustar00rootroot00000000000000;;; -*- Package: HPPA -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/hppa-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the HPPA specific runtime stuff. ;;; (in-package "HPPA") (use-package "SYSTEM") (use-package "ALIEN") (use-package "C-CALL") (intl:textdomain "cmucl") (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) ;;;; The sigcontext structure. #+hpux (def-alien-type save-state (struct nil (regs (array unsigned-long 32)) (ss-cr11 unsigned-long) (ss-pcoq-head unsigned-long) (ss-pcsq-head unsigned-long) (ss-pcoq-tail unsigned-long) (ss-pcsq-tail unsigned-long) (ss_cr15 unsigned-long) (ss_cr19 unsigned-long) (ss_cr20 unsigned-long) (ss_cr21 unsigned-long) (ss_cr22 unsigned-long) (ss_cpustate unsigned-long) (ss_sr4 unsigned-long) (ss_sr0 unsigned-long) (ss_sr1 unsigned-long) (ss_sr2 unsigned-long) (ss_sr3 unsigned-long) (ss_sr5 unsigned-long) (ss_sr6 unsigned-long) (ss_sr7 unsigned-long) (ss_cr0 unsigned-long) (ss_cr8 unsigned-long) (ss_cr9 unsigned-long) (ss_cr10 unsigned-long) (ss_cr12 unsigned-long) (ss_cr13 unsigned-long) (ss_cr24 unsigned-long) (ss_cr25 unsigned-long) (ss_cr26 unsigned-long) (ss_mpsfu_high unsigned-long) (ss_mpsfu_low unsigned-long) (ss_mpsfu_ovflo unsigned-long) (ss_pad unsigned-long) (fpregs (array unsigned-long 32)))) ; union here #+hpux (def-alien-type siglocal (struct nil (sl-syscall unsigned-long) (sl-onstack unsigned-long) (sl-mask unsigned-long) (sl-syscall-action unsigned-char) (sl-eosys unsigned-char) (sl-error unsigned-short) (sl-rval1 unsigned-long) (sl-rval2 unsigned-long) (sl-arg (array unsigned-long 4)) ; ### ? (sl-ss save-state))) #+hpux (def-alien-type unix:sigcontext (struct nil (sc-sl siglocal) ; the rest of this structure left out (since save-state not complete?) )) #+MACH (def-alien-type save-state (struct nil (regs (array unsigned-long 32)) (filler (array unsigned-long 32)) (fpregs (array unsigned-long 32)))) #+MACH (def-alien-type unix:sigcontext (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) (sc-sp system-area-pointer) (sc-fp system-area-pointer) (sc-ap (* save-state)) (sc-pcsqh unsigned-long) (sc-pcoqh unsigned-long) (sc-pcsqt unsigned-long) (sc-pcoqt unsigned-long) (sc-ps unsigned-long))) ;;;; Add machine specific features to *features* (pushnew :hppa *features*) ;;;; MACHINE-TYPE and MACHINE-VERSION (defun machine-type () "Returns a string describing the type of the local machine." "HPPA") (defun machine-version () "Returns a string describing the version of the local machine." "HPPA") ;;; FIXUP-CODE-OBJECT -- Interface ;;; (defun fixup-code-object (code offset value kind) (unless (zerop (rem offset word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (system:without-gcing (let* ((sap (truly-the system-area-pointer (%primitive c::code-instructions code))) (inst (sap-ref-32 sap offset))) (setf (sap-ref-32 sap offset) (ecase kind (:load (logior (ash (ldb (byte 11 0) value) 1) (logand inst #xffffc000))) (:load-short (let ((low-bits (ldb (byte 11 0) value))) (assert (<= 0 low-bits (1- (ash 1 4)))) (logior (ash low-bits 17) (logand inst #xffe0ffff)))) (:hi (logior (ash (ldb (byte 5 13) value) 16) (ash (ldb (byte 2 18) value) 14) (ash (ldb (byte 2 11) value) 12) (ash (ldb (byte 11 20) value) 1) (ldb (byte 1 31) value) (logand inst #xffe00000))) (:branch (let ((bits (ldb (byte 9 2) value))) (assert (zerop (ldb (byte 2 0) value))) (logior (ash bits 3) (logand inst #xffe0e002))))))))) ;;;; Internal-error-arguments. ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((pc (sigcontext-program-counter scp))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-from-system-area pc (* byte-bits 5) vector (* word-bits vector-data-offset) (* length byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) (loop (when (>= index length) (return)) (sc-offsets (c::read-var-integer vector index))) (values error-number (sc-offsets)))))))) ;;;; Sigcontext access functions. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface ;;; (defun sigcontext-program-counter (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) #+hpux (int-sap (logandc2 (slot (slot (slot scp 'sc-sl) 'sl-ss) 'ss-pcoq-head) 3)) #+MACH (int-sap (logandc2 (slot scp 'sc-pcoqh) 3)) )) ;;; SIGCONTEXT-REGISTER -- Interface ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; (defun sigcontext-register (scp index) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) #+hpux (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) #+MACH (deref (slot (slot scp 'sc-ap) 'regs) index) )) (defun %set-sigcontext-register (scp index new) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) #+hpux (setf (deref (slot (slot (slot scp 'sc-sl) 'sl-ss) 'regs) index) new) #+MACH (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new) new)) (defsetf sigcontext-register %set-sigcontext-register) ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; (defun sigcontext-float-register (scp index format) (declare (type (alien (* unix:sigcontext)) scp)) (error "sigcontext-float-register not implemented." scp index format) #+nil (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* unix:sigcontext)) scp)) (error "%set-sigcontext-float-register not implemented." scp index format new-value) #+nil (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; ;;; Given a sigcontext pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp)) (error "sigcontext-floating-point-modes not implimented." scp) #+nil (with-alien ((scp (* unix:sigcontext) scp)) (slot scp 'sc-fpc-csr))) ;;; EXTERN-ALIEN-NAME -- interface. ;;; ;;; The loader uses this to convert alien names to the form they occure in ;;; the symbol table (for example, prepending an underscore). On the HPPA ;;; we just leave it alone. ;;; (defun extern-alien-name (name) (declare (type simple-base-string name)) name) ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; ;;; Do whatever is necessary to make the given code component executable. ;;; On the PA-RISC, this means flushing the data cache and purging the ;;; inst cache. ;;; (defun sanctify-for-execution (component) (without-gcing (alien-funcall (extern-alien "sanctify_for_execution" (function void system-area-pointer unsigned-long)) (code-instructions component) (* (code-header-ref component code-code-size-slot) word-bytes))) nil) cmucl-21a/src/code/hpux-os.lisp000066400000000000000000000043301260377556400165560ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/hpux-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMU CL under Mach. From Miles Bader and David ;;; Axmark. ;;; (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(get-system-info get-page-size os-init)) (pushnew :hpux *features*) (setq *software-type* "HPUX") (defvar *software-version* nil "Version string for supporting software") (defun software-version () "Returns a string describing version of the supporting software." (unless *software-version* (setf *software-version* (let ((version-line (with-output-to-string (stream) (run-program "/usr/bin/uname" '("-r" ) :output stream :pty nil :error nil)))) (subseq version-line 0 (1- (length version-line)))))) *software-version*) ;;; OS-INIT -- interface. ;;; ;;; Other OS dependent initializations. ;;; (defun os-init () ;; Decache version on save, because it might not be the same when we restart. (setf *software-version* nil)) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (cond ((null err?) (error "Unix system call getrusage failed: ~A." (unix:get-unix-error-msg utime))) (T (values utime stime majflt))))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (multiple-value-bind (val err) (unix:unix-getpagesize) (unless val (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err))) val)) cmucl-21a/src/code/internet.lisp000066400000000000000000000726271260377556400170210ustar00rootroot00000000000000;;; -*- Log: code.log; Package: extensions -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/internet.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains an interface to internet domain sockets. ;;; ;;; Written by William Lott. ;;; (in-package "EXTENSIONS") (use-package "ALIEN") (use-package "C-CALL") (intl:textdomain "cmucl") (export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name host-entry-aliases host-entry-addr-list host-entry-addr ip-string bind-inet-socket create-unix-socket connect-to-unix-socket create-unix-listener accept-unix-connection create-inet-socket connect-to-inet-socket create-inet-listener accept-tcp-connection close-socket ipproto-tcp ipproto-udp inaddr-any add-oob-handler remove-oob-handler remove-all-oob-handlers send-character-out-of-band inet-recvfrom inet-sendto inet-shutdown shut-rd shut-wr shut-rdwr open-network-stream accept-network-stream)) #-svr4 (defconstant sock-stream 1) #+svr4 (defconstant sock-stream 2) #-svr4 (defconstant sock-dgram 2) #+svr4 (defconstant sock-dgram 1) #-svr4 (defconstant sock-raw 3) #+svr4 (defconstant sock-raw 4) #+linux (defconstant sock-rdm 4) #+linux (defconstant sock-seqpacket 5) #+linux (defconstant sock-packet 10) (defconstant af-unix 1) ; Unix domain sockets (defconstant af-inet 2) ; Internet IP Protocol #+linux (progn (defconstant af-ax25 3) ; Amateur Radio AX.25 (defconstant af-ipx 4) ; Novell IPX (defconstant af-appletalk 5) ; Appletalk DDP (defconstant af-netrom 6) ; Amateur radio NetROM (defconstant af-bridge 7) ; Multiprotocol bridge (defconstant af-aal5 9) ; Reserved for Werner's ATM (defconstant af-x25 9) ; Reserved for X.25 project (defconstant af-inet6 10) ; IP version 6 (defconstant af-max 12)) (defconstant msg-oob 1) (defconstant msg-peek 2) (defconstant msg-dontroute 4) #+linux (defconstant msg-proxy 16) ;; For errors with socket stuff. (define-condition socket-error (simple-error) ((errno :reader socket-errno :initarg :errno :initform 0))) (defvar *internet-protocols* '((:stream 6 #.sock-stream) (:datagram 17 #.sock-dgram)) "AList of socket kinds and protocol values.") (defun internet-protocol (kind) (when (eq kind :data-gram) ; Sep-2000. Remove someday. (warn (intl:gettext "Internet protocol :DATA-GRAM is deprecated. Using :DATAGRAM")) (setq kind :datagram)) (let ((entry (assoc kind *internet-protocols*))) (unless entry (error (intl:gettext "Invalid kind (~S) for internet domain sockets.") kind)) (values (cadr entry) (caddr entry)))) (defmacro maybe-byte-swap (var bytes) (ecase (c:backend-byte-order c:*backend*) (:big-endian var) (:little-endian (let ((ldbs nil)) (dotimes (i bytes `(logior ,@ldbs)) (push `(ash (ldb (byte 8 ,(* i 8)) ,var) ,(* (- bytes 1 i) 8)) ldbs)))))) (declaim (inline htonl ntohl htons ntohs)) (defun htonl (x) (maybe-byte-swap x 4)) (defun ntohl (x) (maybe-byte-swap x 4)) (defun htons (x) (maybe-byte-swap x 2)) (defun ntohs (x) (maybe-byte-swap x 2)) ;;;; Host entry operations. ;;; Note the IP addresses are stored in host order. (defstruct host-entry name aliases addr-type addr-list) (defun host-entry-addr (host) (declare (type host-entry host)) (car (host-entry-addr-list host))) #-BSD (def-alien-type unix-sockaddr (struct nil (family #-(or linux alpha) short #+(or linux alpha) unsigned-short) (path (array char 108)))) #| struct sockaddr_un { u_char sun_len; /* sockaddr len including null */ u_char sun_family; /* AF_UNIX */ char sun_path[104]; /* path name (gag) */ }; |# #+BSD (def-alien-type unix-sockaddr (struct nil (sun-len unsigned-char) (family unsigned-char) (path (array char 104)))) #| /* * Socket address, internet style. */ struct sockaddr_in { u_char sin_len; u_char sin_family; u_short sin_port; struct in_addr sin_addr; char sin_zero[8]; }; struct in_addr { u_long s_addr; }; |# #+BSD (def-alien-type inet-sockaddr (struct nil (sin-len unsigned-char) (family unsigned-char) (port unsigned-short) (addr unsigned-long) (zero (array char 8)))) #-BSD (def-alien-type inet-sockaddr (struct nil (family #-alpha short #+alpha unsigned-short) (port unsigned-short) (addr #-alpha unsigned-long #+alpha unsigned-int) (zero (array char 8)))) (def-alien-type hostent (struct nil (name c-string) (aliases (* c-string)) (addrtype int) (length int) (addr-list (* (* (unsigned 32)))))) (def-alien-routine "gethostbyname" (* hostent) (name c-string)) (def-alien-routine "gethostbyaddr" (* hostent) (addr unsigned-long :copy) (len int) (type int)) (def-alien-routine ("os_get_h_errno" get-h-errno) int) (defun lookup-host-entry (host) "Return a host-entry for the given host. The host may be an address string or an IP address in host order." (declare (type (or host-entry string (unsigned-byte 32)) host) (optimize (inhibit-warnings 3))) (if (typep host 'host-entry) host (with-alien ((hostent (* hostent) (etypecase host (string (gethostbyname host)) ((unsigned-byte 32) (gethostbyaddr (htonl host) 4 af-inet))))) (if (zerop (sap-int (alien-sap hostent))) (values nil (get-h-errno)) (values (make-host-entry :name (slot hostent 'name) :aliases (collect ((results)) (iterate repeat ((index 0)) (declare (type kernel:index index)) (cond ((or (zerop (sap-int (alien-sap (slot hostent 'aliases)))) (zerop (deref (cast (slot hostent 'aliases) (* (unsigned #-alpha 32 #+alpha 64))) index))) (results)) (t (results (deref (slot hostent 'aliases) index)) (repeat (1+ index)))))) :addr-type (slot hostent 'addrtype) :addr-list (collect ((results)) (iterate repeat ((index 0)) (declare (type kernel:index index)) (cond ((zerop (deref (cast (slot hostent 'addr-list) (* (unsigned #-alpha 32 #+alpha 64))) index)) (results)) (t (results (ntohl (deref (deref (slot hostent 'addr-list) index)))) (repeat (1+ index))))))) t))))) (defun ip-string (addr) (format nil "~D.~D.~D.~D" (ldb (byte 8 24) addr) (ldb (byte 8 16) addr) (ldb (byte 8 8) addr) (ldb (byte 8 0) addr))) (defun create-unix-socket (&optional (kind :stream)) (multiple-value-bind (proto type) (internet-protocol kind) (declare (ignore proto)) (let ((socket (unix:unix-socket af-unix type 0))) (when (minusp socket) (error 'socket-error :format-control (intl:gettext "Error creating socket: ~A") :format-arguments (list (unix:get-unix-error-msg)) :errno (unix:unix-errno))) socket))) (defun connect-to-unix-socket (path &optional (kind :stream)) (declare (simple-string path)) (let ((socket (create-unix-socket kind))) (with-alien ((sockaddr unix-sockaddr)) (setf (slot sockaddr 'family) af-unix) #-unicode (kernel:copy-to-system-area path (* vm:vector-data-offset vm:word-bits) (alien-sap (slot sockaddr 'path)) 0 (* (1+ (length path)) vm:byte-bits)) #+unicode (let ((sap (alien-sap (slot sockaddr 'path))) (len (length path))) ;; FIXME: What should we do about this for unicode? (dotimes (k len) (setf (sap-ref-8 sap k) (logand #xff (char-code (aref path k))))) (setf (sap-ref-8 sap len) 0)) (when (minusp (unix:unix-connect socket (alien-sap sockaddr) (alien-size unix-sockaddr :bytes))) (unix:unix-close socket) (error 'socket-error :format-control (intl:gettext "Error connecting socket to [~A]: ~A") :format-arguments (list path (unix:get-unix-error-msg)) :errno (unix:unix-errno))) socket))) (defun create-unix-listener (path &optional (kind :stream) &key (backlog 5)) (declare (simple-string path)) (let ((socket (create-unix-socket kind))) (with-alien ((sockaddr unix-sockaddr)) ;; I'm here (MSM) (setf (slot sockaddr 'family) af-unix) #-unicode (kernel:copy-to-system-area path (* vm:vector-data-offset vm:word-bits) (alien-sap (slot sockaddr 'path)) 0 (* (1+ (length path)) vm:byte-bits)) #+unicode (let ((sap (alien-sap (slot sockaddr 'path))) (len (length path))) ;; FIXME: What should we do about this for unicode? (dotimes (k len) (setf (sap-ref-8 sap k) (logand #xff (char-code (aref path k))))) (setf (sap-ref-8 sap len) 0)) (when (minusp (unix:unix-bind socket (alien-sap sockaddr) (+ (alien-size inet-sockaddr :bytes) (length path)))) (unix:unix-close socket) (error (intl:gettext "Error binding socket to path ~a: ~a") path (unix:get-unix-error-msg)))) (when (eq kind :stream) (when (minusp (unix:unix-listen socket backlog)) (unix:unix-close socket) (error (intl:gettext "Error listening to socket: ~A") (unix:get-unix-error-msg)))) socket)) (defun accept-unix-connection (unconnected) (declare (fixnum unconnected)) #+MP (mp:process-wait-until-fd-usable unconnected :input) (with-alien ((sockaddr unix-sockaddr)) (let ((connected (unix:unix-accept unconnected (alien-sap sockaddr) (alien-size unix-sockaddr :bytes)))) (when (minusp connected) (error (intl:gettext "Error accepting a connection: ~A") (unix:get-unix-error-msg))) (values connected (slot sockaddr 'path))))) (defun bind-inet-socket (socket host port) "bind Socket to (local) Host and Port" (let ((addr (if (stringp host) (host-entry-addr (or (lookup-host-entry host) (error (intl:gettext "Unknown host: ~S.") host))) host))) (with-alien ((sockaddr inet-sockaddr)) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) (setf (slot sockaddr 'addr) (htonl addr)) (when (minusp (unix:unix-bind socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes))) (let ((errno (unix:unix-errno))) (unix:unix-close socket) (error 'socket-error :format-control (intl:gettext "Error binding socket to port ~A: ~A") :format-arguments (list port (unix:get-unix-error-msg)) :errno errno)))))) (defun create-inet-socket (&optional (kind :stream)) (multiple-value-bind (proto type) (internet-protocol kind) (let ((socket (unix:unix-socket af-inet type proto))) (when (minusp socket) (error 'socket-error :format-control"Error creating socket: ~A" :format-arguments (list (unix:get-unix-error-msg)) :errno (unix:unix-errno))) socket))) (defun connect-to-inet-socket (host port &optional (kind :stream) &key local-host local-port) "The host may be an address string or an IP address in host order." (let* ((addr (if (stringp host) (host-entry-addr (or (lookup-host-entry host) (error (intl:gettext "Unknown host: ~S.") host))) host)) (socket (create-inet-socket kind))) ;; bind to local-host/local-port if given (when (and local-host local-port) (bind-inet-socket socket local-host local-port)) (with-alien ((sockaddr inet-sockaddr)) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) (setf (slot sockaddr 'addr) (htonl addr)) (when (minusp (unix:unix-connect socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes))) ;; unix-close may affect errno; save the current value(s) (let ((errno (unix:unix-errno)) (errmsg (unix:get-unix-error-msg))) (unix:unix-close socket) (error 'socket-error :format-control (intl:gettext "Error connecting socket to [~A:~A]: ~A") :format-arguments (list (if (stringp host) host (ip-string addr)) port errmsg) :errno errno))) socket))) ;; An attempt to rewrite connect-to-inet-socket in such a way that ;; connection attempts that take a long time will not be stuck in the ;; connect(2) system call preventing CMUCL from running other lisp ;; threads. ;; ;; The strategy here is to put the socket in non-blocking mode, and ;; then call connect, which should immediately return. Then there are ;; three cases to handle: ;; ;; I. The connect failed immediately. ;; II. The connect succeeded immediately. ;; III. The connect returned without finishing. ;; ;; Cases I and II are simple enough, we just return the socket or ;; signal an error. ;; ;; In case III, we call SYSTEM:WAIT-UNTIL-FD-IS-USABLE to block just ;; the current thread until the socket is writeable (which signals ;; that the connect has finished, one way or the other). ;; ;; Once WAIT-UNTIL-FD-IS-USABLE returns, we put the socket back into ;; blocking mode and try to determine whether the connect succeeded or ;; failed (and why it failed). We use an approach described at ;; , which is attributed to Douglas ;; C. Schmidt and Ken Keys. ;; ;; First call getpeername, and if it returns 0 the connect succeeded, ;; otherwise it failed. If it failed, we try to read a single ;; character from the socket. We know it can't work, but it should ;; cause errno set to the real reason for the failure. (defun connect-to-inet-socket/non-blocking (host port &optional (kind :stream)) "The host may be an address string or an IP address in host order." (let ((addr (if (stringp host) (host-entry-addr (or (lookup-host-entry host) (error (intl:gettext "Unknown host: ~S.") host))) host)) (socket (create-inet-socket kind))) (labels ((set-blocking (socket) (unix:unix-fcntl socket unix:f-setfl (logior (unix:unix-fcntl socket unix:f-getfl 0) unix:fndelay))) (unset-blocking (socket) (unix:unix-fcntl socket unix:f-setfl (logandc2 (unix:unix-fcntl socket unix:f-getfl 0) unix:fndelay))) (dotted-quad (ipaddr) (let ((naddr (htonl ipaddr))) (format nil "~D.~D.~D.~D" (ldb (byte 8 0) naddr) (ldb (byte 8 8) naddr) (ldb (byte 8 16) naddr) (ldb (byte 8 24) naddr)))) (connect-error (addr reason errno) (error 'socket-error :format-control (intl:gettext "Error connecting socket to [~A:~A]: ~A") :format-arguments (list addr port reason) :errno errno))) (set-blocking socket) (with-alien ((sockaddr inet-sockaddr) (length (alien:array unsigned 1))) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) (setf (slot sockaddr 'addr) (htonl addr)) (let ((retval (unix:unix-connect socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes)))) (cond ((< retval -1) ;; connect failed (let ((reason (unix:get-unix-error-msg)) (errno (unix:unix-errno))) (unix:unix-close socket) (connect-error (if (stringp host) host (dotted-quad addr)) reason errno))) ((= retval -1) ;; connect is in progress (system:wait-until-fd-usable socket :output) (unset-blocking socket) ;; OK, it's done, check whether it worked (when (minusp (unix:unix-getpeername socket (alien-sap sockaddr) (alien-sap length))) (unix:unix-close socket) ;; It didn't, so let's find out why (unix:unix-read socket (alien-sap length) 1) (connect-error (if (stringp host) host (dotted-quad addr)) (unix:get-unix-error-msg) (unix:unix-errno))) socket) (t ;; connect succeeded (unset-blocking socket) socket))))))) ;;; Socket levels. (defconstant sol-socket #+linux 1 #+(or solaris bsd hpux irix) #xffff) ;;; Socket options. (defconstant so-reuseaddr #+linux 2 #+(or solaris bsd hpux irix) 4) (defun get-socket-option (socket level optname) "Get an integer value socket option." (declare (type unix:unix-fd socket) (type (signed-byte 32) level optname)) (with-alien ((optval signed)) (if (minusp (unix:unix-getsockopt socket level optname (alien-sap (addr optval)) 4)) (values nil (unix:unix-errno)) (values optval 0)))) (defun set-socket-option (socket level optname optval) "Set an integer value socket option." (declare (type unix:unix-fd socket) (type (signed-byte 32) level optname optval)) (with-alien ((optval signed optval)) (if (minusp (unix:unix-setsockopt socket level optname (alien-sap (addr optval)) 4)) (values nil (unix:unix-errno)) (values optval 0)))) (defun create-inet-listener (port &optional (kind :stream) &key (host 0) reuse-address (backlog 5) ) (let ((socket (create-inet-socket kind)) (addr (if (stringp host) (host-entry-addr (or (lookup-host-entry host) (error 'socket-error :format-control (intl:gettext "Unknown host: ~S.") :format-arguments (list host) :errno (unix:unix-errno)))) host))) (when reuse-address (multiple-value-bind (optval errno) (set-socket-option socket sol-socket so-reuseaddr 1) (or optval (error 'socket-error :format-control (intl:gettext "Error ~S setting socket option on socket ~D.") :format-arguments (list (unix:get-unix-error-msg errno) socket) :errno errno)))) (with-alien ((sockaddr inet-sockaddr)) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) (setf (slot sockaddr 'addr) (htonl addr)) (when (minusp (unix:unix-bind socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes))) (let ((errno (unix:unix-errno))) (unix:unix-close socket) (error 'socket-error :format-control (intl:gettext "Error binding socket to port ~A: ~A") :format-arguments (list port (unix:get-unix-error-msg)) :errno errno)))) (when (eq kind :stream) (when (minusp (unix:unix-listen socket backlog)) (let ((errno (unix:unix-errno))) (unix:unix-close socket) (error 'socket-error :format-control (intl:gettext "Error listening to socket: ~A") :format-arguments (list (unix:get-unix-error-msg)) :errno errno)))) socket)) (defun accept-tcp-connection (unconnected) (declare (fixnum unconnected)) #+MP (mp:process-wait-until-fd-usable unconnected :input) (with-alien ((sockaddr inet-sockaddr)) (let ((connected (unix:unix-accept unconnected (alien-sap sockaddr) (alien-size inet-sockaddr :bytes)))) (let ((errno (unix:unix-errno))) (when (minusp connected) (error 'socket-error :format-control (intl:gettext "Error accepting a connection: ~A") :format-arguments (list (unix:get-unix-error-msg)) :errno errno)) (values connected (ntohl (slot sockaddr 'addr))))))) (defun close-socket (socket) (multiple-value-bind (ok err) (unix:unix-close socket) (unless ok (error 'socket-error :format-control (intl:gettext "Error closing socket: ~A") :format-arguments (list (unix:get-unix-error-msg err)) :errno (unix:unix-errno)))) (undefined-value)) (defun get-peer-host-and-port (fd) "Return the peer host address and port in host order." (with-alien ((sockaddr inet-sockaddr) (length (alien:array unsigned 1))) (setf (deref length 0) (alien-size inet-sockaddr :bytes)) (when (minusp (unix:unix-getpeername fd (alien-sap sockaddr) (alien-sap length))) (error (intl:gettext "Error ~s getting peer host and port on FD ~d.") (unix:get-unix-error-msg (unix:unix-errno)) fd)) (values (ext:ntohl (slot sockaddr 'addr)) (ext:ntohs (slot sockaddr 'port))))) (defun get-socket-host-and-port (fd) (with-alien ((sockaddr inet-sockaddr) (length (alien:array unsigned 1))) (setf (deref length 0) (alien-size inet-sockaddr :bytes)) (when (minusp (unix:unix-getsockname fd (alien-sap sockaddr) (alien-sap length))) (error (intl:gettext "Error ~s getting socket host and port on FD ~d.") (unix:get-unix-error-msg (unix:unix-errno)) fd)) (values (ext:ntohl (slot sockaddr 'addr)) (ext:ntohs (slot sockaddr 'port))))) ;;;; Out of Band Data. ;;; Two level AList. First levels key is the file descriptor, second levels ;;; key is the character. The datum is the handler to call. (defvar *oob-handlers* nil) ;;; SIGURG-HANDLER -- internal ;;; ;;; Routine that gets called whenever out-of-band data shows up. Checks each ;;; file descriptor for any oob data. If there is any, look for a handler for ;;; that character. If any are found, funcall them. (defun sigurg-handler (signo code scp) (declare (ignore signo code scp)) (let ((buffer (make-string 1)) (handled nil)) (declare (simple-string buffer)) (dolist (handlers *oob-handlers*) (declare (list handlers)) (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob)) (cerror (intl:gettext "Ignore it") (intl:gettext "Error recving oob data on ~A: ~A") (car handlers) (unix:get-unix-error-msg))) (t (setf handled t) (let ((char (schar buffer 0)) (handled nil)) (declare (base-char char)) (dolist (handler (cdr handlers)) (declare (list handler)) (when (eql (car handler) char) (funcall (cdr handler)) (setf handled t))) (unless handled (cerror (intl:gettext "Ignore it") (intl:gettext "No oob handler defined for ~S on ~A") char (car handlers))))))) (unless handled (cerror (intl:gettext "Ignore it") (intl:gettext "Got a SIGURG, but couldn't find any out-of-band data.")))) (undefined-value)) ;;; ADD-OOB-HANDLER -- public ;;; ;;; First, check to see if we already have any handlers for this file ;;; descriptor. If so, just add this handler to them. If not, add this ;;; file descriptor to *OOB-HANDLERS*, make sure our interrupt handler is ;;; installed, and that the given file descriptor is "owned" by us (so sigurg ;;; will be delivered.) (defun add-oob-handler (fd char handler) "Arrange to funcall HANDLER when CHAR shows up out-of-band on FD." (declare (integer fd) (base-char char)) (let ((handlers (assoc fd *oob-handlers*))) (declare (list handlers)) (cond (handlers (push (cons char handler) (cdr handlers))) (t (push (list fd (cons char handler)) *oob-handlers*) (system:enable-interrupt unix:sigurg #'sigurg-handler) #-hpux (unix:unix-fcntl fd unix:f-setown (unix:unix-getpid)) #+hpux (unix:siocspgrp fd (unix:unix-getpid))))) (values)) ;;; REMOVE-OOB-HANDLER -- public ;;; ;;; Delete any handlers for the given char from the list of handlers for the ;;; given file descriptor. If there are no more, nuke the entry for the file ;;; descriptor. (defun remove-oob-handler (fd char) "Remove any handlers for CHAR on FD." (declare (integer fd) (base-char char)) (let ((handlers (assoc fd *oob-handlers*))) (declare (list handlers)) (when handlers (let ((remaining (delete char (cdr handlers) :test #'eql :key #'car))) (declare (list remaining)) (if remaining (setf (cdr handlers) remaining) (setf *oob-handlers* (delete fd *oob-handlers* :test #'eql :key #'car)))))) (values)) ;;; REMOVE-ALL-OOB-HANDLERS -- public ;;; ;;; Delete the entry for the given file descriptor. (defun remove-all-oob-handlers (fd) "Remove all handlers for FD." (declare (integer fd)) (setf *oob-handlers* (delete fd *oob-handlers* :test #'eql :key #'car)) (values)) ;;; SEND-CHARACTER-OUT-OF-BAND -- public ;;; ;;; Sends CHAR across FD out of band. (defun send-character-out-of-band (fd char) (declare (integer fd) (base-char char)) (let ((buffer (make-string 1 :initial-element char))) (declare (simple-string buffer)) (when (minusp (unix:unix-send fd buffer 1 msg-oob)) (error (intl:gettext "Error sending ~S OOB to across ~A: ~A") char fd (unix:get-unix-error-msg))))) (defun inet-recvfrom (fd buffer size &key (flags 0)) "A packaging of the unix recvfrom call. Returns three values: bytecount, source address as integer, and source port. bytecount can of course be negative, to indicate faults." #+mp (mp:process-wait-until-fd-usable fd :input) (with-alien ((sockaddr inet-sockaddr)) (let* ((bytecount (unix:unix-recvfrom fd buffer size flags (alien-sap sockaddr) (alien-size inet-sockaddr :bytes)))) (values bytecount (ntohl (slot sockaddr 'addr)) (ntohs (slot sockaddr 'port)))))) (defun inet-sendto (fd buffer size addr port &key (flags 0)) "A packaging of the unix sendto call. Return value like sendto" (with-alien ((sockaddr inet-sockaddr)) (setf (slot sockaddr 'family) af-inet) (setf (slot sockaddr 'port) (htons port)) (setf (slot sockaddr 'addr) (htonl addr)) (unix:unix-sendto fd buffer size flags (alien-sap sockaddr) (alien-size inet-sockaddr :bytes)))) (defconstant shut-rd 0) (defconstant shut-wr 1) (defconstant shut-rdwr 2) (defun inet-shutdown (fd level) "A packaging of the unix shutdown call. An error is signaled if shutdown fails." (when (minusp (unix:unix-shutdown fd level)) (error 'socket-error :format-control (intl:gettext "Error on shutdown of socket: ~A") :format-arguments (list (unix:get-unix-error-msg)) :errno (unix:unix-errno)))) ;;; OPEN-NETWORK-STREAM -- public ;;; ;;; Returns a stream connected to the specified Port on the given Host. (defun open-network-stream (host port &key (buffering :line) timeout (external-format '(:latin-1 :crlf))) "Return a network stream. HOST may be an address string or an integer IP address." (let (hostent hostaddr) (cond ((stringp host) (setf hostent (or (lookup-host-entry host) (error (intl:gettext "Unknown host: ~S.") host))) (setf host (host-entry-addr hostent)) (setf hostaddr (format nil "~A:~D" (host-entry-name hostent) port))) ((integerp host) (setf hostaddr (format nil "~D.~D.~D.~D:~D" (ldb (byte 8 24) host) (ldb (byte 8 16) host) (ldb (byte 8 8) host) (ldb (byte 8 0) host) port))) (t (error (intl:gettext "Unknown host format: ~S.") host))) (sys:make-fd-stream (let ((socket (create-inet-socket :stream))) (alien:with-alien ((sockaddr inet-sockaddr)) (setf (alien:slot sockaddr 'family) af-inet) (setf (alien:slot sockaddr 'sys:port) (htons port)) (setf (alien:slot sockaddr 'alien:addr) (htonl host)) (when (minusp (unix:unix-connect socket (alien:alien-sap sockaddr) (alien:alien-size inet-sockaddr :bytes))) (unix:unix-close socket) (error (intl:gettext "Error connecting socket to [~A]: ~A") hostaddr (unix:get-unix-error-msg))) socket)) :input t :output t :buffering buffering :timeout timeout :name (format nil (intl:gettext "network connection to ~A") hostaddr) :external-format external-format :auto-close t))) ;;; ACCEPT-NETWORK-STREAM -- public ;;; ;;; Accept a connection from the specified Socket and returns a ;;; stream connected to that connection. (defun accept-network-stream (socket &key (buffering :line) timeout wait-max (external-format '(:latin-1 :crlf))) (declare (fixnum socket)) (when #+MP (mp:process-wait-until-fd-usable socket :input wait-max) #-MP (sys:wait-until-fd-usable socket :input wait-max) (with-alien ((sockaddr inet-sockaddr)) (let ((socket (unix:unix-accept socket (alien-sap sockaddr) (alien-size inet-sockaddr :bytes)))) (when (minusp socket) (error (intl:gettext "Error accepting a connection: ~A") (unix:get-unix-error-msg))) (sys:make-fd-stream socket :input t :output t :buffering buffering :timeout timeout :name (let ((host (ntohl (slot sockaddr 'addr))) (port (ntohs (slot sockaddr 'port)))) (format nil (intl:gettext "network connection from ~D.~D.~D.~D:~D") (ldb (byte 8 24) host) (ldb (byte 8 16) host) (ldb (byte 8 8) host) (ldb (byte 8 0) host) port)) :external-format external-format :auto-close t))))) cmucl-21a/src/code/interr.lisp000066400000000000000000000476721260377556400164760ustar00rootroot00000000000000;;; -*- Log: code.log; Package: KERNEL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/interr.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions and macros to define and deal with internal errors (i.e. ;;; problems that can be signaled from assembler code). ;;; ;;; Written by William Lott. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") (export '(infinite-error-protect find-caller-name *maximum-error-depth* #+stack-checking red-zone-hit #+stack-checking yellow-zone-hit #+heap-overflow-check dynamic-space-overflow-error-hit #+heap-overflow-check dynamic-space-overflow-warning-hit)) ;;;; Internal Errors (defvar *internal-errors* (macrolet ((frob () (map 'vector #'cdr (c:backend-internal-errors c:*backend*)))) (frob))) (eval-when (compile eval) (defmacro deferr (name args &rest body) (let* ((rest-pos (position '&rest args)) (required (if rest-pos (subseq args 0 rest-pos) args)) (fp (gensym "FP-")) (sigcontext (gensym "SIGCONTEXT-")) (sc-offsets (gensym "SC-OFFSETS-")) (temp (gensym)) (fn-name (symbolicate name "-HANDLER"))) `(progn (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets) (declare (ignorable name ,fp ,sigcontext ,sc-offsets)) (macrolet ((set-value (var value) (let ((pos (position var ',required))) (unless pos (error (intl:gettext "~S isn't one of the required args.") var)) `(let ((,',temp ,value)) (di::sub-set-debug-var-slot ,',fp (nth ,pos ,',sc-offsets) ,',temp ,',sigcontext) (setf ,var ,',temp))))) (let (,@(let ((offset -1)) (mapcar #'(lambda (var) `(,var (di::sub-access-debug-var-slot ,fp (nth ,(incf offset) ,sc-offsets) ,sigcontext))) required)) ,@(when rest-pos `((,(nth (1+ rest-pos) args) (mapcar #'(lambda (sc-offset) (di::sub-access-debug-var-slot ,fp sc-offset ,sigcontext)) (nthcdr ,rest-pos ,sc-offsets)))))) ,@body))) (setf (svref *internal-errors* ,(error-number-or-lose name)) #',fn-name)))) ) ; Eval-When (Compile Eval) (deferr unknown-error (&rest args) (error (intl:gettext "Unknown error:~{ ~S~})") args)) (deferr object-not-function-error (object) (error 'type-error :function-name name :datum object :expected-type 'function)) (deferr object-not-list-error (object) (error 'type-error :function-name name :datum object :expected-type 'list)) (deferr object-not-bignum-error (object) (error 'type-error :function-name name :datum object :expected-type 'bignum)) (deferr object-not-ratio-error (object) (error 'type-error :function-name name :datum object :expected-type 'ratio)) (deferr object-not-single-float-error (object) (error 'type-error :function-name name :datum object :expected-type 'single-float)) (deferr object-not-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type 'double-float)) #+long-float (deferr object-not-long-float-error (object) (error 'type-error :function-name name :datum object :expected-type 'long-float)) #+double-double (deferr object-not-double-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type 'double-double-float)) (deferr object-not-simple-string-error (object) (error 'type-error :function-name name :datum object :expected-type 'simple-string)) (deferr object-not-simple-bit-vector-error (object) (error 'type-error :function-name name :datum object :expected-type 'simple-bit-vector)) (deferr object-not-simple-vector-error (object) (error 'type-error :function-name name :datum object :expected-type 'simple-vector)) (deferr object-not-fixnum-error (object) (error 'type-error :function-name name :datum object :expected-type 'fixnum)) (deferr object-not-function-or-symbol-error (object) (error 'type-error :function-name name :datum object :expected-type '(or function symbol))) (deferr object-not-vector-error (object) (error 'type-error :function-name name :datum object :expected-type 'vector)) (deferr object-not-string-error (object) (error 'type-error :function-name name :datum object :expected-type 'string)) (deferr object-not-bit-vector-error (object) (error 'type-error :function-name name :datum object :expected-type 'bit-vector)) (deferr object-not-array-error (object) (error 'type-error :function-name name :datum object :expected-type 'array)) (deferr object-not-number-error (object) (error 'type-error :function-name name :datum object :expected-type 'number)) (deferr object-not-rational-error (object) (error 'type-error :function-name name :datum object :expected-type 'rational)) (deferr object-not-float-error (object) (error 'type-error :function-name name :datum object :expected-type 'float)) (deferr object-not-real-error (object) (error 'type-error :function-name name :datum object :expected-type 'real)) (deferr object-not-integer-error (object) (error 'type-error :function-name name :datum object :expected-type 'integer)) (deferr object-not-cons-error (object) (error 'type-error :function-name name :datum object :expected-type 'cons)) (deferr object-not-symbol-error (object) (error 'type-error :function-name name :datum object :expected-type 'symbol)) (deferr undefined-symbol-error (fdefn-or-symbol) (error 'undefined-function :function-name name :name (etypecase fdefn-or-symbol (symbol fdefn-or-symbol) (fdefn (fdefn-name fdefn-or-symbol))))) (deferr object-not-coercable-to-function-error (object) (error 'type-error :function-name name :datum object :expected-type 'coercable-to-function)) (deferr invalid-argument-count-error (nargs) (error 'simple-program-error :function-name name :format-control (intl:gettext "Invalid number of arguments: ~S") :format-arguments (list nargs))) (deferr bogus-argument-to-values-list-error (list) (error 'simple-type-error :function-name name :datum list :expected-type 'list :format-control (intl:gettext "Attempt to use VALUES-LIST on a dotted-list:~% ~S") :format-arguments (list list))) (deferr unbound-symbol-error (symbol) (error 'unbound-variable :function-name name :name symbol)) (deferr object-not-base-char-error (object) (error 'type-error :function-name name :datum object :expected-type 'base-char)) (deferr object-not-sap-error (object) (error 'type-error :function-name name :datum object :expected-type 'system-area-pointer)) (deferr invalid-unwind-error () (error 'simple-control-error :function-name name :format-control (intl:gettext "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))) (deferr unseen-throw-tag-error (tag) (error 'simple-control-error :function-name name :format-control (intl:gettext "Attempt to THROW to a tag that does not exist: ~S") :format-arguments (list tag))) (deferr nil-function-returned-error (function) (error 'simple-control-error :function-name name :format-control (intl:gettext "Function with declared result type NIL returned:~% ~S") :format-arguments (list function))) (deferr division-by-zero-error (this that) (error 'division-by-zero :function-name name :operation 'division :operands (list this that))) (deferr object-not-type-error (object type) (error (if (and (%instancep object) (layout-invalid (%instance-layout object))) 'layout-invalid 'type-error) :function-name name :datum object :expected-type type)) (deferr layout-invalid-error (object layout) (error 'layout-invalid :function-name name :datum object :expected-type (layout-class layout))) (deferr odd-keyword-arguments-error () (error 'simple-program-error :function-name name :format-control (intl:gettext "Odd number of keyword arguments."))) (deferr unknown-keyword-argument-error (key) (error 'simple-program-error :function-name name :format-control (intl:gettext "Unknown keyword: ~S") :format-arguments (list key))) (deferr invalid-array-index-error (array bound index) (error 'type-error :function-name name :datum index :expected-type `(integer 0 (,bound)) :format-control (cond ((zerop bound) (intl:gettext "Invalid array index, ~D for ~S. Array has no elements.")) ((minusp index) (intl:gettext "Invalid array index, ~D for ~S. Should have greater than or equal to 0.")) (t (intl:gettext "Invalid array index, ~D for ~S. Should have been less than ~D"))) :format-arguments (list index array bound))) (deferr object-not-simple-array-error (object) (error 'type-error :function-name name :datum object :expected-type 'simple-array)) (deferr object-not-signed-byte-32-error (object) (error 'type-error :function-name name :datum object :expected-type '(signed-byte 32))) (deferr object-not-unsigned-byte-32-error (object) (error 'type-error :function-name name :datum object :expected-type '(unsigned-byte 32))) (deferr object-not-simple-array-unsigned-byte-2-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (unsigned-byte 2) (*)))) (deferr object-not-simple-array-unsigned-byte-4-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (unsigned-byte 4) (*)))) (deferr object-not-simple-array-unsigned-byte-8-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (unsigned-byte 8) (*)))) (deferr object-not-simple-array-unsigned-byte-16-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (unsigned-byte 16) (*)))) (deferr object-not-simple-array-unsigned-byte-32-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (unsigned-byte 32) (*)))) (deferr object-not-simple-array-signed-byte-8-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (signed-byte 8) (*)))) (deferr object-not-simple-array-signed-byte-16-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (signed-byte 16) (*)))) (deferr object-not-simple-array-signed-byte-30-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (signed-byte 30) (*)))) (deferr object-not-simple-array-signed-byte-32-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (signed-byte 32) (*)))) (deferr object-not-simple-array-single-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array single-float (*)))) (deferr object-not-simple-array-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array double-float (*)))) #+double-double (deferr object-not-simple-array-double-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array double-double-float (*)))) (deferr object-not-simple-array-complex-single-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (complex single-float) (*)))) (deferr object-not-simple-array-complex-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (complex double-float) (*)))) #+long-float (deferr object-not-simple-array-complex-long-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (complex long-float) (*)))) #+double-double (deferr object-not-simple-array-complex-double-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(simple-array (complex double-double-float) (*)))) (deferr object-not-complex-error (object) (error 'type-error :function-name name :datum object :expected-type 'complex)) (deferr object-not-complex-rational-error (object) (error 'type-error :function-name name :datum object :expected-type '(complex rational))) (deferr object-not-complex-single-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(complex single-float))) (deferr object-not-complex-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(complex double-float))) #+long-float (deferr object-not-complex-long-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(complex long-float))) #+double-double (deferr object-not-complex-double-double-float-error (object) (error 'type-error :function-name name :datum object :expected-type '(complex double-double-float))) (deferr object-not-weak-pointer-error (object) (error 'type-error :function-name name :datum object :expected-type 'weak-pointer)) (deferr object-not-instance-error (object) (error 'type-error :function-name name :datum object :expected-type 'instance)) #+linkage-table (deferr undefined-foreign-symbol-error (symbol) (error 'simple-program-error :function-name name :format-control (intl:gettext "Undefined foreign symbol: ~S") :format-arguments (list symbol))) ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of ;;; hyperspace. ;;; (defmacro infinite-error-protect (&rest forms) `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*)) (let ((*current-error-depth* (1+ *current-error-depth*))) (if (> *current-error-depth* *maximum-error-depth*) (error-error (intl:gettext "Help! ") *current-error-depth* (intl:gettext " nested errors. ") (intl:gettext "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")) (progn ,@forms))) (%primitive halt))) ;;; Track the depth of recursive errors. ;;; (defvar *maximum-error-depth* 10 "The maximum number of nested errors allowed. Internal errors are double-counted.") (defvar *current-error-depth* 0 "The current number of nested errors.") ;;; These specials are used by ERROR-ERROR to track the success of recovery ;;; attempts. ;;; (defvar *error-error-depth* 0) (defvar *error-throw-up-count* 0) ;;; This protects against errors that happen before we run this top-level form. ;;; (defvar *error-system-initialized* t) ;;; ERROR-ERROR can be called when the error system is in trouble and needs ;;; to punt fast. Prints a message without using format. If we get into ;;; this recursively, then halt. ;;; (defun error-error (&rest messages) (let ((*error-error-depth* (1+ *error-error-depth*))) (when (> *error-throw-up-count* 50) (%primitive halt) (throw 'lisp::top-level-catcher nil)) (case *error-error-depth* (1) (2 (lisp::stream-init)) (3 (incf *error-throw-up-count*) (throw 'lisp::top-level-catcher nil)) (t (%primitive halt) (throw 'lisp::top-level-catcher nil))) (with-standard-io-syntax (let ((*print-readably* nil)) (dolist (item messages) (princ item *terminal-io*)) (debug:internal-debug))))) ;;;; Fetching errorful function name. ;;; Used to prevent infinite recursive lossage when we can't find the caller ;;; for some reason. ;;; (defvar *finding-name* nil) ;;; FIND-CALLER-NAME -- Internal ;;; (defun find-caller-name () (if *finding-name* (values "" nil) (handler-case (let* ((*finding-name* t) (frame (di:frame-down (di:frame-down (di:top-frame)))) (name (di:debug-function-name (di:frame-debug-function frame)))) (di:flush-frames-above frame) (values name frame)) (error () (values "" nil)) (di:debug-condition () (values "" nil))))) (defun find-interrupted-name () (if *finding-name* (values "" nil) (handler-case (let ((*finding-name* t)) (do ((frame (di:top-frame) (di:frame-down frame))) ((null frame) (values "" nil)) (when (and (di::compiled-frame-p frame) (di::compiled-frame-escaped frame)) (di:flush-frames-above frame) (return (values (di:debug-function-name (di:frame-debug-function frame)) frame))))) (error () (values "" nil)) (di:debug-condition () (values "" nil))))) ;;;; internal-error signal handler. (defun internal-error (scp continuable) (declare (type system-area-pointer scp) (ignore continuable)) (infinite-error-protect (let ((scp (locally (declare (optimize (inhibit-warnings 3))) (alien:sap-alien scp (* unix:sigcontext))))) (multiple-value-bind (error-number arguments) (vm:internal-error-arguments scp) (multiple-value-bind (name debug:*stack-top-hint*) (find-interrupted-name) (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset))) (handler (and (< -1 error-number (length *internal-errors*)) (svref *internal-errors* error-number)))) (cond ((null handler) (error 'simple-error :function-name name :format-control (intl:gettext "Unknown internal error, ~D? args=~S") :format-arguments (list error-number (mapcar #'(lambda (sc-offset) (di::sub-access-debug-var-slot fp sc-offset scp)) arguments)))) ((not (functionp handler)) (error 'simple-error :function-name name :format-control (intl:gettext "Internal error ~D: ~A. args=~S") :format-arguments (list error-number handler (mapcar #'(lambda (sc-offset) (di::sub-access-debug-var-slot fp sc-offset scp)) arguments)))) (t (funcall handler name fp scp arguments))))))))) ;;; ;;; Called from C when the yellow control stack guard zone is hit. ;;; The yellow zone is unprotected in the C code prior to calling this ;;; function, to give some room for debugging. The red zone is still ;;; protected. ;;; #+stack-checking (defun yellow-zone-hit () (let ((debug:*stack-top-hint* nil)) (format *error-output* _"~2&~@~2%") (infinite-error-protect (error 'stack-overflow)))) ;;; ;;; Called from C when the red control stack guard zone is hit. We ;;; could ABORT here, which would usually take us back to the debugger ;;; or top-level, and add code to the restarts re-protecting the red ;;; zone (which can't be done here because we're still in the red ;;; zone). Using ABORT is too dangerous because users may be using ;;; abort restarts which don't do the necessary re-protecting of the ;;; red zone, and would thus render CMUCL unprotected. ;;; #+stack-checking (defun red-zone-hit () (format *error-output* _"~2&~@~2%") (throw 'lisp::top-level-catcher nil)) #+heap-overflow-check (defun dynamic-space-overflow-warning-hit () (let ((debug:*stack-top-hint* nil)) ;; Don't reserve any more pages (setf lisp::reserved-heap-pages 0) (format *error-output* _"~2&~@~%") (infinite-error-protect (error 'heap-overflow)))) #+heap-overflow-check (defun dynamic-space-overflow-error-hit () (throw 'lisp::top-level-catcher nil)) cmucl-21a/src/code/intl-tramp.lisp000066400000000000000000000013551260377556400172460ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/intl-tramp.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This is a stub for building CMUCL. We need FIND-DOMAIN to be ;;; defined during worldbuild. The real version will get loaded in ;;; intl.lisp during worldload. (in-package "INTL") (defun find-domain (domain locale &optional (locale-dir *locale-directories*)) (declare (ignore domain locale locale-dir)) nil) cmucl-21a/src/code/intl.lisp000066400000000000000000000762361260377556400161370ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- ;;; $Revision: 1.11 $ ;;; Copyright 1999-2010 Paul Foley (mycroft@actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this 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, ;;; provided that the above copyright notice and this permission notice ;;; are included in all copies or substantial portions of the Software. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS ;;; 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 OR CONTRIBUTORS 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. (ext:file-comment "$Header: src/code/intl.lisp $") (in-package "INTL") (eval-when (:compile-toplevel :execute) (defparameter intl::*default-domain* "cmucl") (unless (and (fboundp 'intl:read-translatable-string) (eq (get-macro-character #\_) (fdefinition 'intl:read-translatable-string))) (set-macro-character #\_ (lambda (stream char) (declare (ignore char)) (case (peek-char nil stream nil nil t) (#\" (values)) (#\N (read-char stream t nil t) (values)) (otherwise '_))) t))) (in-package "INTL") (defvar *locale-directories* '(#p"library:locale/" #p"/usr/share/locale/" #p"target:i18n/locale/")) (defvar *locale* "C") (defvar *default-domain* nil "The message-lookup domain used by INTL:GETTEXT and INTL:NGETTEXT. Use (INTL:TEXTDOMAIN \"whatever\") in each source file to set this.") (defvar *loaded-domains* (make-hash-table :test 'equal)) (defvar *locale-aliases* (make-hash-table :test 'equal)) (defstruct domain-entry (domain "" :type simple-base-string) (locale "" :type simple-base-string) (file #p"" :type pathname) (plurals nil :type (or null function)) (hash (make-hash-table :test 'equal) :type hash-table) (encoding nil) (readfn #'identity :type function)) (declaim (ftype (function (stream) (unsigned-byte 32)) read-lelong)) (defun read-lelong (stream) (declare #+(or)(optimize (speed 3) (space 2) (safety 0) #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn (+ (the (unsigned-byte 8) (read-byte stream)) (ash (the (unsigned-byte 8) (read-byte stream)) 8) (ash (the (unsigned-byte 8) (read-byte stream)) 16) (ash (the (unsigned-byte 8) (read-byte stream)) 24))) (declaim (ftype (function (stream) (unsigned-byte 32)) read-belong)) (defun read-belong (stream) (declare #+(or)(optimize (speed 3) (space 2) (safety 0) #+CMU (ext:inhibit-warnings 3))) ;quiet about boxing retn (+ (ash (the (unsigned-byte 8) (read-byte stream)) 24) (ash (the (unsigned-byte 8) (read-byte stream)) 16) (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) (defun locate-domain-file (domain locale locale-dir) ;; The default locale-dir includes search lists. If we get called ;; before the search lists are initialized, we lose. The search ;; lists are initialized in environment-init, which sets ;; *environment-list-initialized*. This way, we return NIL to ;; indicate there's no domain file to use. (when lisp::*environment-list-initialized* (flet ((path (locale base) (merge-pathnames (make-pathname :directory (list :relative locale "LC_MESSAGES") :name domain :type "mo") base))) (let ((locale (or (gethash locale *locale-aliases*) locale))) (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) (let ((probe (or (probe-file (path locale base)) (let ((dot (position #\. locale))) (and dot (probe-file (path (subseq locale 0 dot) base)))) (let ((at (position #\@ locale))) (and at (probe-file (path (subseq locale 0 at) base)))) (let ((us (position #\_ locale))) (and us (probe-file (path (subseq locale 0 us) base))))))) (when probe (return probe)))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain)) (setf (domain-entry-encoding domain) :iso-8859-1) ;; Domain lookup can call the compiler, so set the locale to "C" ;; so things work. (let* ((*locale* "C") (header (domain-lookup "" domain)) (ctype (search "Content-Type: " header)) (eoln (and ctype (position #\Newline header :start ctype))) (charset (and ctype (search "; charset=" header :start2 ctype :end2 eoln)))) (when charset (incf charset 10) (loop for i upfrom charset below eoln as c = (char header i) while (or (alphanumericp c) (eql c #\-)) finally (setf (domain-entry-encoding domain) (intern (nstring-upcase (subseq header charset i)) "KEYWORD")))))) domain) (defun parse-plurals (domain) (let* ((header (domain-lookup "" domain)) (plurals (search "Plural-Forms: " header)) (default (lambda (n) (if (= n 1) 0 1)))) (if (and plurals (> (length header) (+ plurals 36)) (string= header "nplurals=" :start1 (+ plurals 14) :end1 (+ plurals 23))) (let ((nplurals (parse-integer header :start (+ plurals 23) :junk-allowed t)) (point (+ (position #\; header :start (+ plurals 23)) 2))) (if (and (> (length header) (+ point 10)) (string= header "plural=" :start1 point :end1 (+ point 7))) (values (parse-expr header (+ point 7)) nplurals) (values default 2))) (values default 2)))) (defun parse-expr (string pos) (labels ((next () (loop while (member (char string pos) '(#\Space #\Tab #\Newline)) do (incf pos)) (case (char string (1- (incf pos))) (#\n 'n) (#\? 'IF) (#\: 'THEN) (#\( 'LPAR) (#\) 'RPAR) (#\^ 'LOGXOR) (#\+ 'ADD) (#\- 'SUB) (#\* 'MUL) (#\/ 'FLOOR) (#\% 'MOD) (#\~ 'LOGNOT32) (#\; 'END) (#\| (if (char= (char string pos) #\|) (progn (incf pos) 'COR) 'LOGIOR)) (#\& (if (char= (char string pos) #\&) (progn (incf pos) 'CAND) 'LOGAND)) (#\= (if (char= (char string pos) #\=) (progn (incf pos) 'CMP=) (error (intl:gettext "Encountered illegal token: =")))) (#\! (if (char= (char string pos) #\=) (progn (incf pos) 'CMP/=) 'NOT)) (#\< (case (char string pos) (#\= (incf pos) 'CMP<=) (#\< (incf pos) 'SHL) (otherwise 'CMP<))) (#\> (case (char string pos) (#\= (incf pos) 'CMP>=) (#\> (incf pos) 'SHR) (otherwise 'CMP>))) (otherwise (let ((n (digit-char-p (char string (1- pos))))) (if n (loop for nx = (digit-char-p (char string pos)) while nx do (setq n (+ (* n 10) nx)) (incf pos) finally (return n)) (error (intl:gettext "Encountered illegal token: ~C") (char string (1- pos)))))))) (conditional (tok &aux tree) (multiple-value-setq (tree tok) (logical-or tok)) (when (eql tok 'IF) (multiple-value-bind (right next) (logical-or (next)) (unless (eql next 'THEN) (error (intl:gettext "Expected : in ?: construct"))) (multiple-value-bind (else next) (conditional (next)) (setq tree (list tok (list 'zerop tree) else right) tok next)))) (values tree tok)) (logical-or (tok &aux tree) (multiple-value-setq (tree tok) (logical-and tok)) (loop while (eql tok 'COR) do (multiple-value-bind (right next) (logical-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (logical-and (tok &aux tree) (multiple-value-setq (tree tok) (inclusive-or tok)) (loop while (eql tok 'CAND) do (multiple-value-bind (right next) (inclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (inclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (exclusive-or tok)) (loop while (eql tok 'LOGIOR) do (multiple-value-bind (right next) (exclusive-or (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (exclusive-or (tok &aux tree) (multiple-value-setq (tree tok) (bitwise-and tok)) (loop while (eql tok 'LOGXOR) do (multiple-value-bind (right next) (bitwise-and (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (bitwise-and (tok &aux tree) (multiple-value-setq (tree tok) (equality tok)) (loop while (eql tok 'LOGAND) do (multiple-value-bind (right next) (equality (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (equality (tok &aux tree) (multiple-value-setq (tree tok) (relational tok)) (loop while (member tok '(CMP= CMP/=)) do (multiple-value-bind (right next) (relational (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (relational (tok &aux tree) (multiple-value-setq (tree tok) (shift tok)) (loop while (member tok '(CMP< CMP> CMP<= CMP>=)) do (multiple-value-bind (right next) (shift (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (shift (tok &aux tree) (multiple-value-setq (tree tok) (additive tok)) (loop while (member tok '(SHL SHR)) do (multiple-value-bind (right next) (additive (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (additive (tok &aux tree) (multiple-value-setq (tree tok) (multiplicative tok)) (loop while (member tok '(ADD SUB)) do (multiple-value-bind (right next) (multiplicative (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (multiplicative (tok &aux tree) (multiple-value-setq (tree tok) (unary tok)) (loop while (member tok '(MUL FLOOR MOD)) do (multiple-value-bind (right next) (unary (next)) (setq tree (list tok tree right) tok next))) (values tree tok)) (unary (tok &aux tree) (cond ((eq tok 'LPAR) (multiple-value-setq (tree tok) (conditional (next))) (unless (eq tok 'RPAR) (error (intl:gettext "Expected close-paren."))) (values tree (next))) ((numberp tok) (values tok (next))) ((eql tok 'n) (values tok (next))) ((eql tok 'ADD) (unary (next))) ((eql tok 'SUB) (multiple-value-setq (tree tok) (unary (next))) (values (list '- tree) tok)) ((eql tok 'LOGNOT32) (multiple-value-setq (tree tok) (unary (next))) (values (list 'LOGNOT32 tree) tok)) ((eql tok 'NOT) (multiple-value-setq (tree tok) (unary (next))) (values (list 'CNOT tree) tok)) (t (error (intl:gettext "Unexpected token: ~S.") tok))))) (multiple-value-bind (tree end) (conditional (next)) (unless (eq end 'END) (error (intl:gettext "Expecting end of expression. ~S.") end)) (let ((*compile-print* nil)) (compile nil `(lambda (n) (declare (type (unsigned-byte 32) n) (optimize (space 3))) (flet ((add (a b) (ldb (byte 32 0) (+ a b))) (sub (a b) (ldb (byte 32 0) (- a b))) (mul (a b) (ldb (byte 32 0) (* a b))) (shl (a b) (ldb (byte 32 0) (ash a b))) (shr (a b) (ash a (- b))) (cmp= (a b) (if (= a b) 1 0)) (cmp/= (a b) (if (/= a b) 1 0)) (cmp< (a b) (if (< a b) 1 0)) (cmp<= (a b) (if (<= a b) 1 0)) (cmp> (a b) (if (> a b) 1 0)) (cmp>= (a b) (if (>= a b) 1 0)) (cand (a b) (if (or (zerop a) (zerop b)) 0 1)) (cor (a b) (if (and (zerop a) (zerop b)) 0 1)) (cnot (a) (if a 0 1)) (lognot32 (a) (ldb (byte 32 0) (lognot a)))) (declare (ignorable #'add #'sub #'mul #'shr #'shl #'cmp= #'cmp/= #'cmp< #'cmp<= #'cmp> #'cmp>= #'cand #'cor #'cnot #'lognot32)) ,tree))))))) (defun load-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((file (locate-domain-file domain locale locale-dir)) (read #'read-lelong)) (unless file (let ((entry (make-domain-entry :domain domain :locale locale :hash (make-hash-table :size 0 :test 'equal)))) (setf (gethash domain *loaded-domains*) entry) (return-from load-domain entry))) (with-open-file (stream file :direction :input :if-does-not-exist nil :element-type '(unsigned-byte 8)) (unless stream (return-from load-domain nil)) (let ((magic (read-lelong stream))) (cond ((= magic #x950412de) (setq read #'read-lelong)) ((= magic #xde120495) (setq read #'read-belong)) (t ;; DON'T translate this! If we can't load the domain, ;; we can't print this message, Which causes an error ;; that causes use to do a domain lookup again, which ;; fails which cause an error message which ... (warn "Bad magic number in \"~A.mo\"." domain) (return-from load-domain nil)))) (let ((version (funcall read stream)) (messages (funcall read stream)) (master (funcall read stream)) (translation (funcall read stream)) (entry (make-domain-entry))) (declare (ignore version)) (setf (domain-entry-readfn entry) read) (setf (domain-entry-domain entry) domain) (setf (domain-entry-locale entry) locale) (setf (domain-entry-file entry) file) (dotimes (msg messages) (file-position stream (+ master (* 8 msg))) (let ((length (funcall read stream)) (start (funcall read stream))) (setf (gethash length (domain-entry-hash entry)) (acons start (+ translation (* 8 msg)) (gethash length (domain-entry-hash entry)))))) (setf (gethash domain *loaded-domains*) entry) (find-encoding entry))))) (defun find-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((found (gethash domain *loaded-domains*))) (if (and found (string= (domain-entry-locale found) locale)) found (load-domain domain locale locale-dir)))) (declaim (inline string-to-octets)) (defun string-to-octets (string encoding) (declare (ignorable encoding)) #+(and CMU Unicode) (ext:string-to-octets string :external-format encoding) #+Allegro (excl:string-to-octets string :external-format encoding :null-terminate nil) #+SBCL (sb-ext:string-to-octets string :external-format encoding :null-terminate nil) #+CLISP ;;@@ Not sure if encoding keyword is OK here (ext:convert-string-to-bytes string encoding) ;;@@ add other implementations #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) (map-into (make-array (length string) :element-type '(unsigned-byte 8)) #'char-code string)) (declaim (inline octets-to-string)) (defun octets-to-string (octets encoding) (declare (ignorable encoding)) #+(and CMU Unicode) (ext:octets-to-string octets :external-format encoding) #+Allegro (excl:octets-to-string octets :external-format encoding :end (length octets)) #+SBCL (sb-ext:octets-to-string octets :external-format encoding) #+CLISP ;;@@ Not sure if encoding keyword is OK here (ext:convert-string-from-bytes octets encoding) ;;@@ add other implementations #-(or (and CMU Unicode) Allegro SBCL CLISP #|others|#) (map-into (make-string (length octets)) #'code-char octets)) (defun octets= (a b &key (start1 0) (end1 (length a)) (start2 0) (end2 (length b))) (declare (type (simple-array (unsigned-byte 8) (*)) a b) (type (integer 0 #.array-dimension-limit) start1 end1 start2 end2) #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0))) (when (and (< start1 end1) (< start2 end2)) (loop (unless (= (aref a start1) (aref b start2)) (return nil)) (when (or (= (incf start1) end1) (= (incf start2) end2)) (return t))))) (defun search-domain (octets domain pos) (declare (type (simple-array (unsigned-byte 8) (*)) octets) (type domain-entry domain) (type list pos) #+(or)(optimize (speed 3) (space 2) (safety 0) #-gcl (debug 0) #+CMU (ext:inhibit-warnings 3))) ; quiet about boxing (when pos (let ((temp (make-array 120 :element-type '(unsigned-byte 8))) (length (length octets))) (with-open-file (stream (domain-entry-file domain) :direction :input :element-type '(unsigned-byte 8)) (dolist (entry pos) (file-position stream (car entry)) (let ((off 0) (end (read-sequence temp stream :end (min 120 length)))) (declare (type (integer 0 #.array-dimension-limit) off end)) (loop while (octets= octets temp :start1 off :end1 (min (+ off 120) length) :end2 end) do (incf off end) (when (< off length) (setf end (read-sequence temp stream :end (min 120 (- length off)))))) (when (= off length) (file-position stream (cdr entry)) (let* ((len (funcall (domain-entry-readfn domain) stream)) (off (funcall (domain-entry-readfn domain) stream)) (tmp (make-array len :element-type '(unsigned-byte 8)))) (file-position stream off) (read-sequence tmp stream) (return (values tmp entry)))))))))) (defun domain-lookup (string domain) (declare (type string string) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) (or (if (null (domain-entry-encoding domain)) string) (gethash string (domain-entry-hash domain)) (let* ((octets (string-to-octets string (domain-entry-encoding domain))) (length (length octets)) (pos (gethash length (domain-entry-hash domain)))) (declare (type (simple-array (unsigned-byte 8) (*)) octets)) (multiple-value-bind (tmp entry) (search-domain octets domain pos) (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) (when tmp (let ((temp (delete entry pos :test #'eq))) (if temp (setf (gethash length (domain-entry-hash domain)) temp) (remhash length (domain-entry-hash domain)))) (setf (gethash (copy-seq string) (domain-entry-hash domain)) (octets-to-string tmp (domain-entry-encoding domain)))))))) (defun domain-lookup-plural (singular plural domain) (declare (type string singular plural) (type domain-entry domain) #+(or)(optimize (speed 3) (space 2) (safety 0))) (when (domain-entry-encoding domain) (or (gethash (cons singular plural) (domain-entry-hash domain)) (let* ((octets (let* ((a (string-to-octets singular (domain-entry-encoding domain))) (b (string-to-octets plural (domain-entry-encoding domain))) (c (make-array (+ (length a) (length b) 1) :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (*)) a b c)) (replace c a) (setf (aref c (length a)) 0) (replace c b :start1 (+ (length a) 1)) c)) (length (length octets)) (pos (gethash length (domain-entry-hash domain)))) (declare (type (simple-array (unsigned-byte 8) (*)) octets) (type list pos)) (multiple-value-bind (tmp entry) (search-domain octets domain pos) (declare (type (or null (simple-array (unsigned-byte 8) (*))) tmp)) (when tmp (prog1 (setf (gethash (cons (copy-seq singular) (copy-seq plural)) (domain-entry-hash domain)) (loop for i = 0 then (1+ j) as j = (position 0 tmp :start i) collect (octets-to-string (subseq tmp i j) (domain-entry-encoding domain)) while j)) (let ((temp (delete entry pos :test #'eq))) (if temp (setf (gethash length (domain-entry-hash domain)) temp) (remhash length (domain-entry-hash domain)))) (when (null (domain-entry-plurals domain)) (setf (domain-entry-plurals domain) (parse-plurals domain)))))))))) (declaim (inline getenv) (ftype (function (string) (or null string)) getenv)) (defun getenv (var) (let ((val #+(or CMU SCL) (cdr (assoc (intern var "KEYWORD") ext:*environment-list*)) #+SBCL (sb-ext:posix-getenv var) #+Allegro (system:getenv var) #+LispWorks (hcl:getenv var) #+clisp (ext:getenv var) #+(or openmcl mcl) (ccl::getenv var) #+(or gcl ecl) (si::getenv var))) (if (equal val "") nil val))) (defun setlocale (&optional locale) (setf *locale* (or locale (getenv "LANGUAGE") (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG") *locale*))) (defmacro textdomain (domain) `(eval-when (:compile-toplevel :execute) (setf *default-domain* ,domain))) ;; Set the textdomain to New-Domain for the body and then restore the ;; domain to the original. (defmacro with-textdomain ((old-domain new-domain) &body body) `(progn (intl:textdomain ,new-domain) ,@body (intl:textdomain ,old-domain))) (defmacro gettext (string) "Look up STRING in the current message domain and return its translation." `(dgettext ,*default-domain* ,string)) (defmacro ngettext (singular plural n) "Look up the singular or plural form of a message in the current domain." `(dngettext ,*default-domain* ,singular ,plural ,n)) (declaim (inline dgettext)) (defun dgettext (domain string) "Look up STRING in the specified message domain and return its translation." #+(or)(declare (optimize (speed 3) (space 2) (safety 0))) (let ((domain (and domain (find-domain domain *locale*)))) (or (and domain (domain-lookup string domain)) string))) (defun dngettext (domain singular plural n) "Look up the singular or plural form of a message in the specified domain." (declare (type integer n) #+(or)(optimize (speed 3) (space 2) (safety 0))) (let* ((domain (and domain (find-domain domain *locale*))) (list (and domain (domain-lookup-plural singular plural domain)))) (if list (nth (the integer (funcall (the function (domain-entry-plurals domain)) n)) list) (if (= n 1) singular plural)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #-runtime (defvar *translator-comment* nil) #-runtime (defvar *translations* nil) #-runtime (defun translation-enable () (setq *translations* (or *translations* (make-hash-table :test 'equal))) t) #-runtime (defun translation-disable () (setq *translations* nil)) #-runtime (defun note-translatable (domain string &optional plural) (when (and domain *translations*) (let* ((hash (or (gethash domain *translations*) (setf (gethash domain *translations*) (make-hash-table :test 'equal)))) (key (if plural (cons string plural) string)) (val (or (gethash key hash) (cons nil nil)))) (pushnew *translator-comment* (car val) :test #'equal) (pushnew (and *compile-file-truename* (enough-namestring *compile-file-truename*)) (cdr val) :test #'equal) ;; FIXME: How does this happen? Need to figure this out and get ;; rid of this! (unless key (warn "Translate error with null key. domain = ~S string = ~S~%" domain string)) (setf (gethash key hash) val))) (setq *translator-comment* nil)) (define-compiler-macro dgettext (&whole form domain string) #-runtime (when (and (stringp domain) (stringp string)) (note-translatable domain string)) form) (define-compiler-macro dngettext (&whole form domain singular plural n) (declare (ignore n)) #-runtime (when (and (stringp domain) (stringp singular) (stringp plural)) (note-translatable domain singular plural)) form) (defun read-translatable-string (stream char) (declare (ignore char)) (case (peek-char nil stream nil nil t) (#\" (let* ((*read-suppress* nil) (string (read stream t nil t))) (note-translatable *default-domain* string) `(gettext ,string))) (#\N (read-char stream t nil t) (let* ((*read-suppress* nil) (string (read stream t nil t))) #-runtime (note-translatable *default-domain* string) string)) (#\@ (error _"_@ is a reserved reader macro prefix.")) (otherwise (let ((fn (get-macro-character #\_ nil))) (if fn (funcall fn stream #\_) '_))))) ;; Process comments as usual, but look for lines that begin with ;; "TRANSLATORS: ". These lines are saved and written out as a ;; translator comment for the next translatable string. #-runtime (defun read-comment (stream char) (declare (optimize (speed 0) (space 3) #-gcl (debug 0)) (ignore char)) (do ((state 0) (index 0) (text nil) (char (read-char stream nil nil t) (read-char stream nil nil t))) ((or (not char) (char= char #\Newline)) (when text (setq *translator-comment* (copy-seq text)))) (cond ((and (= state 0) (char= char #\Space)) (setq state 1)) ((and (= state 0) (char= char #\T)) (setq state 1 index 1)) ((and (= state 0) (char/= char #\;)) (setq state 2)) ((and (= state 1) (= index 0) (char= char #\Space)) #|ignore|#) ((= state 1) (if (char= char (char "TRANSLATORS: " index)) (when (= (incf index) 13) (setq state 3)) (setq state 2))) ((= state 3) (when (null text) (setq text (make-array 50 :element-type 'character :adjustable t :fill-pointer 0))) (vector-push-extend char text)))) (values)) #-runtime (defun read-nested-comment (stream subchar arg) (declare (ignore subchar arg) (optimize (speed 0) (space 3) #-gcl (debug 0))) (do ((level 1) (state 0) (index 0) (text nil) (prev (read-char stream t nil t) char) (char (read-char stream t nil t) (read-char stream t nil t))) (()) (cond ((and (char= prev #\|) (char= char #\#)) (when (zerop (decf level)) (when text (setq *translator-comment* (string-right-trim '(#\Space #\Newline) text))) (return))) ((and (char= prev #\#) (char= char #\|)) (setq state 2) (incf level)) ((and (= state 0) (char= prev #\Space)) (setq state 1)) ((and (= state 0) (char= prev #\T)) (setq state 1 index 1)) ((= state 0) (setq state 2)) ((and (= state 1) (= index 0) (char= prev #\Space)) #| ignore |#) ((= state 1) (if (char= prev (char "TRANSLATORS: " index)) (when (= (incf index) 13) (setq state 3)) (setq state 2))) ((= state 3) (when (null text) (setq text (make-array 50 :element-type 'character :adjustable t :fill-pointer 0))) (vector-push-extend prev text)))) (values)) (defun install (&optional (rt *readtable*)) (set-macro-character #\_ #'read-translatable-string t rt) #-runtime (set-macro-character #\; #'read-comment nil rt) #-runtime (set-dispatch-macro-character #\# #\| #'read-nested-comment rt) t) ;; Dump the translatable strings. The output is written to a file in ;; the directory OUTPUT-DIRECTORY and its name is the domain. #-runtime (defun dump-pot-files (&key copyright output-directory) ;;(declare (optimize (speed 0) (space 3) #-gcl (debug 1))) (labels ((b (key data) (format t "~@[~{~&#. ~A~}~%~]" (delete nil (car data))) (format t "~@[~&~<#: ~@;~@{~A~^ ~}~:@>~%~]" (delete nil (cdr data))) (cond ((consp key) (format t "~&msgid ") (str (car key) 6 0) (format t "~&msgid_plural ") (str (cdr key) 13 0) (format t "~&msgstr[0] \"\"~2%")) (t (cond (key (format t "~&msgid ") (str key 6 0) (format t "~&msgstr \"\"~2%")) (t (format *error-output* "Skipping NIL key~%")))))) (str (string col start) (when (and (plusp col) (> (length string) (- 76 col))) (format t "\"\"~%")) (let ((nl (position #\Newline string :start start))) (cond ((and nl (< (- nl start) 76)) (write-char #\") (wstr string start nl) (format t "\\n\"~%") (str string 0 (1+ nl))) ((< (- (length string) start) 76) (write-char #\") (wstr string start (length string)) (write-char #\")) (t (let* ((a (+ start 1)) (b (+ start 76)) (b1 (position #\Space string :start a :end b :from-end t)) (b2 (position-if (lambda (x) (position x ";:,?!)]}")) string :start a :end b :from-end t)) (b3 (position-if (lambda (x) (position x "\"'-")) string :start a :end b :from-end t)) (b4 (position-if #'digit-char-p string :start a :end b :from-end t)) (b5 (position-if #'alpha-char-p string :start a :end b :from-end t)) (g1 (if b1 (* (- b b1) (- b b1) .03) 10000)) (g2 (if b2 (* (- b b2) (- b b2) .20) 10000)) (g3 (if b3 (* (- b b3) (- b b3) .97) 10000)) (g4 (if b4 (* (- b b4) (- b b4) 1.3) 10000)) (g5 (if b5 (* (- b b5) (- b b5) 2.0) 10000)) (g (min g1 g2 g3 g4 g5)) (end (1+ (cond ((> g 750) b) ((= g g1) b1) ((= g g2) b2) ((= g g3) b3) ((= g g4) b4) ((= g g5) b5))))) #+(or) (progn (format t "~&Splitting ~S:~%" (subseq string start b)) (format t "~{~& b~D=~D; goodness=~F~}~%" (list 1 b1 g1 2 b2 g2 3 b3 g3 4 b4 g4 5 b5 g5 6 b 10000)) (format t "~& best=~F == ~D~%" g end) (format t "~& Part1=~S~% Part2=~S~%" (subseq string start end) (subseq string end b))) (write-char #\") (wstr string start end) (write-char #\") (terpri) (str string 0 end)))))) (wstr (string start end) (loop while (< start end) do (let ((i (position-if (lambda (x) (or (char= x #\") (char= x #\\))) string :start start :end end))) (write-string string nil :start start :end (or i end)) (when i (write-char #\\ nil) (write-char (char string i) nil)) (setq start (if i (1+ i) end))))) (a (domain hash) (format t _"~&Dumping ~D messages for domain ~S~%" (hash-table-count hash) domain) (with-open-file (*standard-output* (merge-pathnames (make-pathname :name domain :type "pot") output-directory) :direction :output :if-exists :supersede :external-format :iso8859-1 ) (format t "~&#@ ~A~2%" domain) (format t "~&# SOME DESCRIPTIVE TITLE~%") (format t "~@[~&# Copyright (C) YEAR ~A~%~]" copyright) (format t "~&# FIRST AUTHOR , YEAR~%") (format t "~&#~%#, fuzzy~%msgid \"\"~%msgstr \"\"~%") (format t "~&\"Project-Id-Version: PACKAGE VERSION\\n\"~%") (format t "~&\"Report-Msgid-Bugs-To: \\n\"~%") (format t "~&\"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"~%") (format t "~&\"Last-Translator: FULL NAME \\n\"~%") (format t "~&\"Language-Team: LANGUAGE \\n\"~%") (format t "~&\"MIME-Version: 1.0\\n\"~%") (format t "~&\"Content-Type: text/plain; charset=UTF-8\\n\"~%") (format t "~&\"Content-Transfer-Encoding: 8bit\\n\"~2%") (maphash #'b hash)))) (maphash #'a *translations*) #+(or) (clrhash *translations*)) nil) (eval-when (:compile-toplevel :execute) (setq *default-domain* nil) (unless (and (fboundp 'intl:read-translatable-string) (eq (get-macro-character #\_) (fdefinition 'intl:read-translatable-string))) (set-syntax-from-char #\_ #\_))) ;; Don't install the reader macros by default. #+(or) (install) cmucl-21a/src/code/irix-os.lisp000066400000000000000000000043211260377556400165450ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/irix-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMU CL under IRIX. ;;; ;;; (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(get-system-info get-page-size os-init)) (pushnew :irix *features*) (pushnew :svr4 *features*) (setq *software-type* "IRIX") (defvar *software-version* nil "Version string for supporting software") (defun software-version () "Returns a string describing version of the supporting software." (unless *software-version* (setf *software-version* (let ((version-line (with-output-to-string (stream) (run-program "/usr/bin/uname" '("-r" ) :output stream :pty nil :error nil)))) (subseq version-line 0 (1- (length version-line)))))) *software-version*) ;;; OS-INIT -- interface. ;;; ;;; Other OS dependent initializations. ;;; (defun os-init () ;; Decache version on save, because it might not be the same when we restart. (setf *software-version* nil)) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (cond ((null err?) (error "Unix system call getrusage failed: ~A." (unix:get-unix-error-msg utime))) (T (values utime stime majflt))))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (multiple-value-bind (val err) (unix:unix-getpagesize) (unless val (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err))) val)) cmucl-21a/src/code/irrat-dd.lisp000066400000000000000000002022521260377556400166640ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/irrat-dd.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains all the irrational functions for double-double ;;; float. The algorithms and coefficients come from the Cephes math ;;; library. See http://www.moshier.net/#Cephes and ;;; http://www.netlib.org/cephes/. ;;; ;;; Author: Raymond Toy. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") ;;;; Random constants, utility functions. (defconstant max-log 7.0978271289338399678773454114191w2 _N"log(most-positive-double-double-float)") (defconstant min-log -7.4444007192138126231410729844608w2 _N"log(least-positive-double-double-float") (defconstant loge2 0.6931471805599453094172321214581765680755001w0 _N"log(2)") (defconstant log2e 1.442695040888963407359924681001892137426646w0 _N"Log base 2 of e") (defconstant log2ea 4.4269504088896340735992468100189213742664595w-1 _N"log2(e)-1") ;; l102a+log102b = log10(2) to extra precision (defconstant l102a 0.3125w0) (defconstant l102b -1.14700043360188047862611052755069732318101185w-2) ;; l10ea + l10eb = log10(2) to extra precsion (defconstant l10ea 0.5w0) (defconstant l10eb -6.570551809674817234887108108339491770560299w-2) (defconstant dd-pi 3.141592653589793238462643383279502884197169w0 _N"Pi") (defconstant dd-pi/2 1.570796326794896619231321691639751442098585w0 _N"Pi/2") (defconstant dd-pi/4 0.7853981633974483096156608458198757210492923w0 _N"Pi/4") ;; dd-pi/4-lo is such that dd-pi/4-lo + dd-pi/4 is equal to pi/4 to ;; twice the precision of a double-double-float. (defconstant dd-pi/4-lo -7.486924524295848886603985669688687133352026408988280860093283232w-34 ) ;; log2-c1 and log-c2 are log(2) arranged in such a way that log2-c1 + ;; log2-c2 is log(2) to an accuracy greater than double-double-float. (defconstant log2-c1 6.93145751953125w-1) (defconstant log2-c2 1.428606820309417232121458176568075500134w-6) (defconstant sqrt-1/2 0.7071067811865475244008443621048490392848w0 _N"Sqrt(1/2)") ;; Evaluate polynomial (declaim (maybe-inline poly-eval poly-eval-1)) (defun poly-eval (x coef) (declare (type double-double-float x) (type (simple-array double-double-float (*)) coef) (optimize (speed 3) (space 0) (inhibit-warnings 3))) ;; y = C0 + C1*x + C2*x^2 + ... ;; ;; But coefficients are stored in reverse (descending powers) order: ;; coef[0] = CN, ..., coef[N] = C0. (let ((y 0w0)) (declare (type double-double-float y)) (loop for c across coef do (setf y (+ (* y x) c))) y)) (defun poly-eval-1 (x coef) (declare (type double-double-float x) (type (simple-array double-double-float (*)) coef) (optimize (speed 3) (space 0) (inhibit-warnings 3))) ;; Like poly-eval, except it assumes coef[N] = 1 and is omitted. (let ((y 1w0)) (declare (type double-double-float y)) (loop for c across coef do (setf y (+ (* y x) c))) y)) ;;; dd-%expm1 ;;; ;;; exp(x)-1 ;;; Range reduction is accomplished by separating the argument ;;; into an integer k and fraction f such that ;;; ;;; x k f ;;; e = 2 e. ;;; ;;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1 ;;; in the basic range [-0.5 ln 2, 0.5 ln 2]. ;;; ;;; ;;; ACCURACY: ;;; ;;; Relative error: ;;; arithmetic domain # trials peak rms ;;; IEEE -79,+MAXLOG 100,000 1.7e-34 4.5e-35 ;;; (let ((p (make-array 8 :element-type 'double-double-float :initial-contents '( -4.888737542888633647784737721812546636240w-1 4.401308817383362136048032038528753151144w1 -1.716772506388927649032068540558788106762w3 4.578962475841642634225390068461943438441w4 -7.212432713558031519943281748462837065308w5 8.944630806357575461578107295909719817253w6 -5.722847283900608941516165725053359168840w7 2.943520915569954073888921213330863757240w8))) (q (make-array 8 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 -8.802340681794263968892934703309274564037w1 3.697714952261803935521187272204485251835w3 -9.615511549171441430850103489315371768998w4 1.682912729190313538934190635536631941751w6 -2.019684072836541751428967854947019415698w7 1.615869009634292424463780387327037251069w8 -7.848989743695296475743081255027098295771w8 1.766112549341972444333352727998584753865w9))) ;; ln 2^-114 (minarg -7.9018778583833765273564461846232128760607w1)) (declare (type double-double-float minarg)) ;; exp(x) - 1 = x + 0.5*x^2+x^3*P(x)/Q(x), for -log(2)/2 < x < ;; log(2)/2, where the coefficients of P and Q are given Pn and Qn ;; above. Theoretical peak relative error = 8.1e-36. (defun dd-%expm1 (x) _N"exp(x) - 1" (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) ;; Range reduction is accomplished by separating the argument ;; into an integer k and fraction f such that ;; ;; x k f ;; e = 2 e. ;; ;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1 ;; in the basic range [-0.5 ln 2, 0.5 ln 2]. (when (> x max-log) (return-from dd-%expm1 (kernel:%make-double-double-float #.ext:double-float-positive-infinity #.ext:double-float-positive-infinity))) (when (< x minarg) (return-from dd-%expm1 -1w0)) ;; Express x = ln(2)*(k+remainder), remainder not exceeding 1/2 (let* ((xx (+ log2-c1 log2-c2)) (k (floor (+ 0.5w0 (/ (the (double-double-float * 710w0) x) xx)))) (px (coerce k 'double-double-float)) (qx 0w0)) (declare (type double-double-float xx px qx)) ;; remainder times ln 2 (decf x (* px log2-c1)) (decf x (* px log2-c2)) ;; Approximate exp(remainder*ln(2)) (setf px (* x (poly-eval x p))) (setf qx (poly-eval-1 x q)) (setf xx (* x x)) (setf qx (+ x (+ (* 0.5w0 xx) (/ (* xx px) qx)))) ;; exp(x) = exp(k*ln(2))*exp(remainder*ln(2)) = 2^k*exp(remainder*ln(2)) ;; ;; We have qx = exp(remainder*ln(2))-1, so exp(x) - 1 = ;; 2^k*(qx+1)-1 = 2^k*qx + 2^k - 1 (setf px (scale-float 1w0 k)) (+ (* px qx) (- px 1))))) ;;; dd-%exp ;;; exp(x) ;;; Range reduction is accomplished by separating the argument ;;; into an integer k and fraction f such that ;;; ;;; x k f ;;; e = 2 e. ;;; ;;; A Pade' form of degree 2/3 is used to approximate exp(f) - 1 ;;; in the basic range [-0.5 ln 2, 0.5 ln 2]. ;;; ;;; ;;; ACCURACY: ;;; ;;; Relative error: ;;; arithmetic domain # trials peak rms ;;; IEEE +-MAXLOG 100,000 2.6e-34 8.6e-35 ;;; ;;; ;;; Error amplification in the exponential function can be ;;; a serious matter. The error propagation involves ;;; exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), ;;; which shows that a 1 lsb error in representing X produces ;;; a relative error of X times 1 lsb in the function. ;;; While the routine gives an accurate result for arguments ;;; that are exactly represented by a long double precision ;;; computer number, the result contains amplified roundoff ;;; error for large arguments not exactly represented. (let ((p (make-array 5 :element-type 'double-double-float :initial-contents '( 3.279723985560247033712687707263393506266w-10 6.141506007208645008909088812338454698548w-7 2.708775201978218837374512615596512792224w-4 3.508710990737834361215404761139478627390w-2 9.999999999999999999999999999999999998502w-1 ))) (q (make-array 6 :element-type 'double-double-float :initial-contents '( 2.980756652081995192255342779918052538681w-12 1.771372078166251484503904874657985291164w-8 1.504792651814944826817779302637284053660w-5 3.611828913847589925056132680618007270344w-3 2.368408864814233538909747618894558968880w-1 2.000000000000000000000000000000000000150w0 ))) ;; C1 + C2 = ln 2 (c1 (- log2-c1)) (c2 (- log2-c2))) (declare (type double-double-float c1 c2)) ;; p and q are Pade coefficients for exp(x) - 1. Theoretical peak ;; relative error = 2.2e-37, relative peak error spread = 9.2e-38. (defun dd-%exp (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (> x max-log) (return-from dd-%exp (kernel:%make-double-double-float #.ext:double-float-positive-infinity #.ext:double-float-positive-infinity))) (when (< x min-log) (return-from dd-%exp 0w0)) ;; Express ;; exp(x) = exp(g)*2^n ;; = exp(g)*exp(n*log(2)) ;; = exp(g + n * log2) (let* ((n (floor (+ 0.5w0 (* x log2e)))) (px (coerce n 'double-double-float))) (declare (type double-double-float px)) (incf x (* px c1)) (incf x (* px c2)) ;; Rational approx for exponential of fractional part: ;; exp(x) = 1+2*x*p(x^2)/(q(x^2)-p(x^2)) ;; ;; [The above comment seems not to match the code below. But ;; perhaps q(x) isn't what I think it is.] (let ((xx (* x x))) (setf px (* x (poly-eval xx p))) (setf xx (poly-eval xx q)) (setf x (/ px (- xx px))) (setf x (+ 1 x x)) (scale-float x n))))) ;;; dd-%log ;;; log(x), natural logarithm. ;;; The argument is separated into its exponent and fractional ;;; parts. If the exponent is between -1 and +1, the logarithm ;;; of the fraction is approximated by ;;; ;;; log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). ;;; ;;; Otherwise, setting z = 2(x-1)/x+1), ;;; ;;; log(x) = z + z**3 P(z)/Q(z). ;;; ;;; ;;; ;;; ACCURACY: ;;; ;;; Relative error: ;;; arithmetic domain # trials peak rms ;;; IEEE exp(+-MAXLOGL) 36,000 9.5e-35 4.1e-35 ;;; (let ((p (make-array 13 :element-type 'double-double-float :initial-contents '(1.538612243596254322971797716843006400388w-6 4.998469661968096229986658302195402690910w-1 2.321125933898420063925789532045674660756w1 4.114517881637811823002128927449878962058w2 3.824952356185897735160588078446136783779w3 2.128857716871515081352991964243375186031w4 7.594356839258970405033155585486712125861w4 1.797628303815655343403735250238293741397w5 2.854829159639697837788887080758954924001w5 3.007007295140399532324943111654767187848w5 2.014652742082537582487669938141683759923w5 7.771154681358524243729929227226708890930w4 1.313572404063446165910279910527789794488w4))) (q (make-array 12 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 4.839208193348159620282142911143429644326w1 9.104928120962988414618126155557301584078w2 9.147150349299596453976674231612674085381w3 5.605842085972455027590989944010492125825w4 2.248234257620569139969141618556349415120w5 6.132189329546557743179177159925690841200w5 1.158019977462989115839826904108208787040w6 1.514882452993549494932585972882995548426w6 1.347518538384329112529391120390701166528w6 7.777690340007566932935753241556479363645w5 2.626900195321832660448791748036714883242w5 3.940717212190338497730839731583397586124w4))) (r (make-array 6 :element-type 'double-double-float :initial-contents '(-8.828896441624934385266096344596648080902w-1 8.057002716646055371965756206836056074715w1 -2.024301798136027039250415126250455056397w3 2.048819892795278657810231591630928516206w4 -8.977257995689735303686582344659576526998w4 1.418134209872192732479751274970992665513w5 ))) (s (make-array 6 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 -1.186359407982897997337150403816839480438w2 3.998526750980007367835804959888064681098w3 -5.748542087379434595104154610899551484314w4 4.001557694070773974936904547424676279307w5 -1.332535117259762928288745111081235577029w6 1.701761051846631278975701529965589676574w6)))) ;; p and q are coefficients in the expansion for log(1+x) = x - ;; x^2/2 + x^3*p(x)/q(x), where 1/sqrt(2) <= 1+x < sqrt(2). ;; Theoretical peak relative error = 5.3e-37, relative peak error ;; spread = 2.3e-14. ;; ;; R and S are coefficients for log(x) = z + z^3*r(z^2)/s(z^2), ;; where z = 2*(x-1)/(x+1), where 1/sqrt(2) <= x < sqrt(2). ;; Theoretical peak relative error = 1.1e-35, relative peak error ;; spread 1.1e-9. ;; ;; (defun dd-%log (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) ;; Separate mantissa from exponent (multiple-value-bind (x e sign) (decode-float x) (declare (type double-double-float x) (type double-float-exponent e)) (when (zerop x) ;; Handle log(+/-0). Return -inf or -inf + i*pi, but signal a ;; division by zero. (return-from dd-%log (if (minusp sign) (complex (/ (- x)) dd-pi) (/ (- x))))) (let ((z 0w0) (y 0w0)) (declare (type double-double-float z y)) ;; Logarithm using log(x) = z + z^3*P(z^2)/Q(z^2); where z = 2*(x-1)/x + 1; (cond ((or (> e 2) (< e -2)) (cond ((< x sqrt-1/2) ;; 2*(2*x-1)/(2*x+1) (decf e) (setf z (- x 0.5w0)) (setf y (+ (* 0.5w0 z) 0.5w0))) (t ;; 2*(x-1)/(x+1) (setf z (- x 0.5w0)) (decf z 0.5w0) (setf y (+ (* 0.5w0 x) 0.5w0)))) (setf x (/ z y)) (setf z (* x x)) (setf z (* x (/ (* z (poly-eval z r)) (poly-eval-1 z s)))) (incf z (* e log2-c2)) (incf z x) (incf z (* e log2-c1))) (t ;; Log using log(1+x) = x - 0.5*x^2+x^3*p(x)/q(x) (cond ((< x sqrt-1/2) (decf e) (setf x (- (scale-float x 1) 1))) (t (decf x))) (setf z (* x x)) (setf y (* x (* z (/ (poly-eval x p) (poly-eval-1 x q))))) (incf y (* e log2-c2)) ;; z = y - 0.5*z (setf z (- y (scale-float z -1))) (incf z x) (incf z (* e log2-c1)) )))))) ;;; dd-%log1p(x) ;;; log(1+x) ;;; ;;; The argument 1+x is separated into its exponent and fractional ;;; parts. If the exponent is between -1 and +1, the logarithm ;;; of the fraction is approximated by ;;; ;;; log(1+x) = x - 0.5 x^2 + x^3 P(x)/Q(x). ;;; ;;; Otherwise, setting z = 2(x-1)/x+1), ;;; ;;; log(x) = z + z^3 P(z)/Q(z). ;;; ;;; ;;; ;;; ACCURACY: ;;; ;;; Relative error: ;;; arithmetic domain # trials peak rms ;;; IEEE -1, 8 100000 1.9e-34 4.3e-35 (let ((p (make-array 13 :element-type 'double-double-float :initial-contents '( 1.538612243596254322971797716843006400388w-6 4.998469661968096229986658302195402690910w-1 2.321125933898420063925789532045674660756w1 4.114517881637811823002128927449878962058w2 3.824952356185897735160588078446136783779w3 2.128857716871515081352991964243375186031w4 7.594356839258970405033155585486712125861w4 1.797628303815655343403735250238293741397w5 2.854829159639697837788887080758954924001w5 3.007007295140399532324943111654767187848w5 2.014652742082537582487669938141683759923w5 7.771154681358524243729929227226708890930w4 1.313572404063446165910279910527789794488w4 ))) (q (make-array 12 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 4.839208193348159620282142911143429644326w1 9.104928120962988414618126155557301584078w2 9.147150349299596453976674231612674085381w3 5.605842085972455027590989944010492125825w4 2.248234257620569139969141618556349415120w5 6.132189329546557743179177159925690841200w5 1.158019977462989115839826904108208787040w6 1.514882452993549494932585972882995548426w6 1.347518538384329112529391120390701166528w6 7.777690340007566932935753241556479363645w5 2.626900195321832660448791748036714883242w5 3.940717212190338497730839731583397586124w4 ))) (r (make-array 6 :element-type 'double-double-float :initial-contents '(-8.828896441624934385266096344596648080902w-1 8.057002716646055371965756206836056074715w1 -2.024301798136027039250415126250455056397w3 2.048819892795278657810231591630928516206w4 -8.977257995689735303686582344659576526998w4 1.418134209872192732479751274970992665513w5 ))) (s (make-array 6 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 -1.186359407982897997337150403816839480438w2 3.998526750980007367835804959888064681098w3 -5.748542087379434595104154610899551484314w4 4.001557694070773974936904547424676279307w5 -1.332535117259762928288745111081235577029w6 1.701761051846631278975701529965589676574w6 ))) ) ;; Coefficients for log(1+x) = x - x^2 / 2 + x^3 P(x)/Q(x) ;; 1/sqrt(2) <= 1+x < sqrt(2) ;; Theoretical peak relative error = 5.3e-37, ;; relative peak error spread = 2.3e-14 (defun dd-%log1p (xm1) (declare (type double-double-float xm1) (optimize (space 0))) (let ((x (+ xm1 1)) (z 0w0) (y 0w0)) (declare (type double-double-float x y z) (optimize (speed 3) (inhibit-warnings 3))) (multiple-value-bind (x e) (decode-float x) (declare (type double-double-float x) (type double-float-exponent e)) (cond ((or (> e 2) (< e -2)) ;; Log using log(x) = z + z^3*P(z^2)/Q(z^2) (cond ((< x sqrt-1/2) (decf e) (setf z (- x 0.5w0)) (setf y (+ 0.5w0 (* 0.5w0 z)))) (t (setf z (- x 0.5w0)) (decf z 0.5w0) (setf y (+ 0.5w0 (* 0.5w0 x))))) (setf x (/ z y)) (setf z (* x x)) (setf z (* x (/ (* z (poly-eval z r)) (poly-eval-1 z s)))) (incf z (* e log2-c2)) (incf z x) (incf z (* e log2-c1))) (t ;; Log using log(1+x) = x - 0.5*x^2 + x^3*p(x)/q(x) (cond ((< x sqrt-1/2) (decf e) (if (/= e 0) (setf x (- (* 2 x) 1)) (setf x xm1))) (t (if (/= e 0) (decf x 1) (setf x xm1)))) (setf z (* x x)) (setf y (* x (/ (* z (poly-eval x p)) (poly-eval-1 x q)))) (incf y (* e log2-c2)) (setf z (- y (* 0.5w0 z))) (incf z x) (incf z (* e log2-c1)))))))) (let ((P (make-array 6 :element-type 'double-double-float :initial-contents '( 1.622194395724068297909052717437740288268w3 1.124862584587770079742188354390171794549w6 3.047548980769660162696832999871894196102w8 3.966215348072348368191433063260384329745w10 2.375869584584371194838551715348965605295w12 6.482835792103233269752264509192030816323w13 ))) (Q (make-array 6 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ -9.101683853129357776079049616394849086007w2 4.486400519836461218634448973793765123186w5 -1.492531313030440305095318968983514314656w8 3.457771488856930054902696708717192082887w10 -5.193289868803472640225483235513427062460w12 3.889701475261939961851358705515223019890w14)))) (defun dd-%sinh (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (let ((a (abs x))) (declare (type double-double-float a)) (cond ((> a 1) (setf a (dd-%exp a)) (setf a (- (* 0.5w0 a) (/ 0.5w0 a))) (if (< x 0) (- a) a)) (t (setf a (* a a)) (let ((pp (poly-eval a p)) (qq (poly-eval-1 a q))) (+ x (* x a (/ pp qq))))))))) #+nil (defun dd-%sinh (x) (declare (type double-double-float x)) (let ((a (abs x))) (declare (type double-double-float a)) (cond ((> a 1) (setf a (dd-%exp a)) (setf a (- (* 0.5w0 a) (/ 0.5w0 a))) (if (< x 0) (- a) a)) (t ;; Use sinh(x) = 1/2*(D(x)+D(x)/(1+D(x))), here D(x) = ;; exp(x)-1. (let ((d (dd-%expm1 x))) (* 0.5w0 (+ d (/ d (+ 1 d))))))))) (defun dd-%cosh (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (let ((y (dd-%exp x))) (scale-float (+ y (/ y)) -1))) (let ((P (make-array 6 :element-type 'double-double-float :initial-contents '(-6.505693197948351084912624750702492767503w-6 -9.804083860188429726356968570322356183383w-1 -5.055287638900473250703725789725376004355w2 -7.307477148073823966594990496301416814519w4 -3.531606586182691280701462523692471322688w6 -4.551377146142783468144190926206842300707w7 ))) (Q (make-array 5 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ 5.334865598460027935735737253027154828002w2 8.058475607422391042912151298751537172870w4 4.197073523796142343374222405869721575491w6 6.521134551226147545983467868553677881771w7 1.365413143842835040443257277862054198329w8)))) (defun dd-%tanh (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (let ((z (abs x))) (declare (type double-double-float z)) (cond ((> z (* 0.5w0 max-log)) (if (> x 0) 1w0 -1w0)) ((> z 0.625w0) (let ((s (dd-%exp (* 2 z)))) (setf z (- 1 (/ 2 (+ s 1)))) (if (minusp x) (- z) z))) (t (let* ((s (* x x))) (declare (optimize speed)) (setf z (/ (poly-eval s p) (poly-eval-1 s q))) (setf z (* x s z)) (+ x z))))))) (let ((P (make-array 10 :element-type 'double-double-float :initial-contents '( -9.217569843805850417698565442251656375681w-1 5.321929116410615470118183794063211260728w1 -9.139522976807685333981548145417830690552w2 7.204314536952949779101646454146682033772w3 -3.097809640165146436529075324081668598891w4 7.865376554210973897486215630898496100534w4 -1.211716814094785128366087489224821937203w5 1.112669508789123834670923967462068457013w5 -5.600242872292477863751728708249167956542w4 1.188901082233997739779618679364295772810w4 ))) (Q (make-array 10 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ -6.807348436010016270202879229504392062418w1 1.386763299649315831625106608182196351693w3 -1.310805752656879543134785263832907269320w4 6.872174720355764193772953852564737816928w4 -2.181008360536226513009076189881617939380w5 4.362736119602298592874941767284979857248w5 -5.535251007539393347687001489396152923502w5 4.321594849688346708841188057241308805551w5 -1.894075056489862952285849974761239845873w5 3.566703246701993219338856038092901974725w4 )))) (defun dd-%atanh (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((minusp x) (- (the double-double-float (dd-%atanh (- x))))) ((< x 1w-12) x) ((< x 0.5w0) (let ((z (* x x))) (+ x (* x z (/ (poly-eval z p) (poly-eval-1 z q)))))) (t (* 0.5w0 (dd-%log (/ (+ 1 x) (- 1 x)))))))) (let ((P (make-array 9 :element-type 'double-double-float :initial-contents '( -8.104404283317298189545629468767571317688w-1 -4.954206127425209147110732546633675599008w1 -8.438175619831548439550086251740438689853w2 -6.269710069245210459536983820505214648057w3 -2.418935474493501382372711518024193326434w4 -5.208121780431312783866941311277024486498w4 -6.302755086521614763280617114866439227971w4 -4.003566436224198252093684987323233921339w4 -1.037690841528359305134494613113086980551w4 ))) (Q (make-array 9 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ 8.175806439951395194771977809279448392548w1 1.822215299975696008284027212745010251320w3 1.772040003462901790853111853838978236828w4 9.077625379864046240143413577745818879353w4 2.675554475070211205153169988669677418808w5 4.689758557916492969463473819426544383586w5 4.821923684550711724710891114802924039911w5 2.682316388947175963642524537892687560973w5 6.226145049170155830806967678679167550122w4)))) (defun dd-%asinh (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((minusp x) (- (the double-double-float (dd-%asinh (- x))))) #+nil ((> x 1w10) (+ loge2 (dd-%log x))) ((< x 0.5w0) (let* ((z (* x x)) (a (* z (/ (poly-eval z p) (poly-eval-1 z q))))) (+ (* a x) x))) (t (dd-%log (+ x (sqrt (1+ (* x x))))))))) (let ((P (make-array 10 :element-type 'double-double-float :initial-contents '( 1.895467874386341763387398084072833727168w-1 6.443902084393244878979969557171256604767w1 3.914593556594721458616408528941154205393w3 9.164040999602964494412169748897754668733w4 1.065909694792026382660307834723001543839w6 6.899169896709615182428217047370629406305w6 2.599781868717579447900896150777162652518w7 5.663733059389964024656501196827345337766w7 6.606302846870644033621560858582696134512w7 3.190482951215438078279772140481195200593w7 ))) (Q (make-array 9 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ 1.635418024331924674147953764918262009321w2 7.290983678312632723073455563799692165828w3 1.418207894088607063257675159183397062114w5 1.453154285419072886840913424715826321357w6 8.566841438576725234955968880501739464425w6 3.003448667795089562511136059766833630017w7 6.176592872899557661256383958395266919654w7 6.872176426138597206811541870289420510034w7 3.190482951215438078279772140481195226621w7 )))) (defun dd-%acosh (x) (declare (type (double-double-float 1w0) x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((> x 1w17) (+ loge2 (dd-%log x))) (t (let ((z (- x 1))) (cond ((< z 0.5w0) (* (sqrt (* 2 z)) (/ (poly-eval z p) (poly-eval-1 z q)))) (t (dd-%log (+ x (sqrt (* z (+ 1 x)))))))))))) (let ((P (make-array 10 :element-type 'double-double-float :initial-contents '( -8.067112765482705313585175280952515549833w-1 4.845649797786849136525020822000172350977w1 -8.510195404865297879959793548843395926847w2 6.815196841370292688574521445731895826485w3 -2.967135182120339728996157454994675519735w4 7.612250656518818109652985996692466409670w4 -1.183360579752620455689557157684221905030w5 1.095432262510413338755837156377401348063w5 -5.554124580991113991999636773382495788705w4 1.187132626694762543537732514905488896985w4 ))) (Q (make-array 10 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ -8.005471061732009595694099899234272342478w1 1.817324228942812880965069608562483918025w3 -1.867017317425756524289537002141956583706w4 1.048196619402464497478959760337779705622w5 -3.527040897897253459022458866536165564103w5 7.426302422018858001691440351763370029242w5 -9.863068411558756277454631976667880674474w5 8.025654653926121907774766642393757364326w5 -3.653000557802254281954969843055623398839w5 7.122795760168575261226395089432959614179w4 )))) (defun dd-%asin (x) (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((minusp x) (- (the double-double-float (dd-%asin (- x))))) #+nil ((< x 1w-8) x) (t (multiple-value-bind (flag z zz) (cond ((> x 0.5w0) (let* ((zz1 (- 0.5w0 x)) (zz (scale-float (+ zz1 0.5w0) -1))) (values t (sqrt zz) zz))) (t (values nil x (* x x)))) (declare (type double-double-float z zz)) (let ((p (* zz (/ (poly-eval zz p) (poly-eval-1 zz q))))) (setf z (+ (* z p) z)) (when flag (setf z (+ z z)) (setf z (- dd-pi/2 z))) z)))))) (defun dd-%acos (x) (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((< x -0.5w0) (- dd-pi (* 2 (dd-%asin (sqrt (* 0.5w0 (+ 1 x))))))) ((> x 0.5w0) (* 2 (dd-%asin (sqrt (* 0.5w0 (- 1w0 x)))))) (t (- dd-pi/2 (dd-%asin x))))) (let ((P (make-array 9 :element-type 'double-double-float :initial-contents '( -6.635810778635296712545011270011752799963w-4 -8.768423468036849091777415076702113400070w-1 -2.548067867495502632615671450650071218995w1 -2.497759878476618348858065206895055957104w2 -1.148164399808514330375280133523543970854w3 -2.792272753241044941703278827346430350236w3 -3.696264445691821235400930243493001671932w3 -2.514829758941713674909996882101723647996w3 -6.880597774405940432145577545328795037141w2 ))) (Q (make-array 8 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ 3.566239794444800849656497338030115886153w1 4.308348370818927353321556740027020068897w2 2.494680540950601626662048893678584497900w3 7.928572347062145288093560392463784743935w3 1.458510242529987155225086911411015961174w4 1.547394317752562611786521896296215170819w4 8.782996876218210302516194604424986107121w3 2.064179332321782129643673263598686441900w3 ))) ;; tan( 3*pi/8 ) (T3P8 2.414213562373095048801688724209698078569672w0) ;; tan( pi/8 ) (TP8 0.414213562373095048801688724209698078569672w0)) (declare (type double-double-float t3p8 tp8)) (defun dd-%atan (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (minusp x) (return-from dd-%atan (- (the double-double-float (dd-%atan (- x)))))) ;; range reduction (let ((y 0w0)) (declare (type double-double-float y)) (cond ((> x t3p8) (setf y dd-pi/2) (setf x (/ -1 x))) ((> x tp8) (setf y dd-pi/4) (setf x (/ (- x 1) (+ x 1)))) (t (setf y 0w0))) ;; Rational form in x^2 (let ((z (* x x))) (setf y (+ y (* (/ (poly-eval z p) (poly-eval-1 z q)) z x) x)) y)))) (defun dd-%atan2 (y x) (declare (type double-double-float x y) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (let ((code 0) (neg-x (minusp (float-sign x))) (neg-y (minusp (float-sign y)))) (declare (type (integer 0 3) code)) (when neg-x (setf code 2)) (when neg-y (setf code (logior code 1))) ;; Handle the case where x or y is zero, taking into account the ;; sign of the zero. (cond ((zerop x) ;; x = 0. (cond ((zerop y) ;; x = 0, y = 0 ;; ;; CLHS Figure 12-15 shows what the results should ;; be. (if neg-x (if neg-y (- dd-pi) dd-pi) (if neg-y -0w0 0w0))) (t ;; x = 0, y /= 0 (if neg-y (- dd-pi/2) dd-pi/2)))) ((zerop y) ;; y = 0, x /= 0 (cond (neg-x (if neg-y (- dd-pi) dd-pi)) (t (if neg-y -0w0 0w0)))) (t (let ((w (ecase code (0 ;; x > 0, y > 0 0w0) (1 ;; x > 0, y < 0 -0w0) (2 ;; x < 0, y > 0 dd-pi) (3 ;; x < 0, y < 0 (- dd-pi))))) (+ w (dd-%atan (/ y x)))))))) ;; ;; Here are the fractional digits of pi, in hex. ;; ;; 243f6a8885 a308d31319 8a2e037073 44a4093822 299f31d008 2efa98ec4e 6c89452821 e638d01377 be5466cf34 e90c6cc0ac ;; 29b7c97c50 dd3f84d5b5 b547091792 16d5d98979 fb1bd1310b a698dfb5ac 2ffd72dbd0 1adfb7b8e1 afed6a267e 96ba7c9045 ;; ;; We want to express pi/4 in 3 parts such that the sum of the parts ;; is exactly the value of pi to the higher precision. For ;; double-double, we want 53 bits in each part. ;; ;; pi/4 in hex is ;; ;; C90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411 ;; ;; #|| (let* ((frac #xC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411) (len (integer-length frac))) (format t "len = ~D bits~%" len) (format t "pi/4 ~,,' ,106:b~%" (ldb (byte (* 4 106) (- len (* 4 106))) frac))) -> pi/4 11001001000011111101101010100010001000010110100011000 01000110100110001001100011001100010100010111000000011 01110000011100110100010010100100000010010011100000100 01000101001100111110011000111010000000010000010111011 ||# ;; d1 = (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106) ;; d2 = (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106)) ;; d3 = (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106)) ;; d4 = (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106)) ;; sin(x) = x + x^3 P(x^2) ;; Theoretical peak relative error = 5.6e-39 ;; relative peak error spread = 1.7e-9 (defconstant sincof (make-array 12 :element-type 'double-double-float :initial-contents '( 6.410290407010279602425714995528976754871w-26 -3.868105354403065333804959405965295962871w-23 1.957294039628045847156851410307133941611w-20 -8.220635246181818130416407184286068307901w-18 2.811457254345322887443598804951004537784w-15 -7.647163731819815869711749952353081768709w-13 1.605904383682161459812515654720205050216w-10 -2.505210838544171877505034150892770940116w-8 2.755731922398589065255731765498970284004w-6 -1.984126984126984126984126984045294307281w-4 8.333333333333333333333333333333119885283w-3 -1.666666666666666666666666666666666647199w-1 ))) ;; Compute sin(x) for |x| < pi/4 (approx). (defun dd-%%sin (x) (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 2) (space 0) (inhibit-warnings 3))) (if (< (abs (double-double-hi x)) (scale-float 1d0 -52)) x (let ((x2 (* x x))) (+ x (* x (* x2 (poly-eval x2 sincof))))))) ;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2)) ;; Theoretical peak relative error = 2.1e-37, ;; relative peak error spread = 1.4e-8 (defconstant coscof (make-array 11 :element-type 'double-double-float :initial-contents '( 1.601961934248327059668321782499768648351w-24 -8.896621117922334603659240022184527001401w-22 4.110317451243694098169570731967589555498w-19 -1.561920696747074515985647487260202922160w-16 4.779477332386900932514186378501779328195w-14 -1.147074559772972328629102981460088437917w-11 2.087675698786809897637922200570559726116w-9 -2.755731922398589065255365968070684102298w-7 2.480158730158730158730158440896461945271w-5 -1.388888888888888888888888888765724370132w-3 4.166666666666666666666666666666459301466w-2 ))) ;; Compue cos(x) for |x| < pi/4 (approx) (defun dd-%%cos (x) (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 2) (space 0) (inhibit-warnings 3))) (let ((x2 (* x x))) (+ (- 1 (scale-float x2 -1)) (* x2 (poly-eval x2 coscof) x2)))) ;; Compute tan(x) or cot(x) for |x| < pi/4 (approx). If cotflag is ;; non-nil, cot(x) is returned. Otherwise, return tan(x). (let ((P (make-array 6 :element-type 'double-double-float :initial-contents '( -9.889929415807650724957118893791829849557w-1 1.272297782199996882828849455156962260810w3 -4.249691853501233575668486667664718192660w5 5.160188250214037865511600561074819366815w7 -2.307030822693734879744223131873392503321w9 2.883414728874239697964612246732416606301w10 ))) (Q (make-array 6 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ -1.317243702830553658702531997959756728291w3 4.529422062441341616231663543669583527923w5 -5.733709132766856723608447733926138506824w7 2.758476078803232151774723646710890525496w9 -4.152206921457208101480801635640958361612w10 8.650244186622719093893836740197250197602w10 )))) (defun dd-tancot (x cotflag) (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 2) (space 0) (inhibit-warnings 3))) (let* ((xx (* x x)) (y (if (> xx 1w-40) (+ x (* x (* xx (/ (poly-eval xx p) (poly-eval-1 xx q))))) x))) (if cotflag (/ y) y)))) (defun dd-%%tan (x extra) (declare (type double-double-float x) (double-float extra)) (cond ((>= (abs x) 0.6744) ;; For 0.6744 <= |x| <= pi/4, we want to use the relationship ;; ;; tan(x) = tan(pi/4-y) = (1 - tan(y))/(1 + tan(y)) ;; = 1 - 2*(tan(y) - tan(y)^2)/(1+tan(y)) (if (minusp x) (- (dd-%%tan (- x) (- extra))) (let* ((z (- dd-pi/4 x)) (w (- dd-pi/4-lo extra)) (tan (dd-tancot (+ z w) nil))) (- 1 (/ (* 2 (- tan (* tan tan))) (+ 1 tan)))))) (t (dd-tancot x nil)))) (declaim (inline %kernel-rem-pi/2)) (alien:def-alien-routine ("__kernel_rem_pio2" %kernel-rem-pi/2) c-call:int (x (* double-float)) (y (* double-float)) (e0 c-call:int) (nx c-call:int) (prec c-call:int) (ipio2 (* c-call:int))) ;; This is taken from two_over_pi in fdlibm's e_rem_pio2.c. We do ;; this here so that the Sparc version doesn't have to compile in ;; e_rem_pio2, which we don't need. (But x86 and ppc do.) (defconstant two-over-pi (make-array 66 :element-type '(unsigned-byte 32) :initial-contents '(#xA2F983 #x6E4E44 #x1529FC #x2757D1 #xF534DD #xC0DB62 #x95993C #x439041 #xFE5163 #xABDEBB #xC561B7 #x246E3A #x424DD2 #xE00649 #x2EEA09 #xD1921C #xFE1DEB #x1CB129 #xA73EE8 #x8235F5 #x2EBB44 #x84E99C #x7026B4 #x5F7E41 #x3991D6 #x398353 #x39F49C #x845F8B #xBDF928 #x3B1FF8 #x97FFDE #x05980F #xEF2F11 #x8B5A0A #x6D1F6D #x367ECF #x27CB09 #xB74F46 #x3F669E #x5FEA2D #x7527BA #xC7EBE5 #xF17B3D #x0739F7 #x8A5292 #xEA6BFB #x5FB11F #x8D5D08 #x560330 #x46FC7B #x6BABF0 #xCFBC20 #x9AF436 #x1DA9E3 #x91615E #xE61B08 #x659985 #x5F14A0 #x68408D #xFFD880 #x4D7327 #x310606 #x1556CA #x73A8C9 #x60E27B #xC08C6B )) _N"396 (hex) digits of 2/pi") (let ((y (make-array 3 :element-type 'double-float)) (parts (make-array 5 :element-type 'double-float))) (declare (type (simple-array double-float (3)) y) (type (simple-array double-float (5)) parts)) ;; Take the double-double-float number and break it into 24-bit ;; chunks. Each chunk is an integer, which is coerced to a ;; double-float and stored in PARTS. (defun dd-expand (x) (declare (double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (multiple-value-bind (frac exp) (decode-float x) (declare (double-double-float frac) (type (signed-byte 16) exp)) (setf frac (scale-float frac 24)) (decf exp 24) (dotimes (k 5) (setf (aref parts k) (coerce (ffloor frac) 'double-float)) (setf frac (scale-float (- frac (aref parts k)) 24))) exp)) (defun reduce-arg (x) (declare (double-double-float x) (optimize (speed 3) (inhibit-warnings 3))) (let* ((e0 (dd-expand x)) (n (sys:without-gcing (%kernel-rem-pi/2 (vector-sap parts) (vector-sap y) e0 (length parts) 3 (vector-sap two-over-pi)))) (sum (+ (coerce (aref y 1) 'double-double-float) (coerce (aref y 0) 'double-double-float)))) (values n sum (aref y 2))))) (declaim (ftype (function (double-double-float) double-double-float) dd-%sin)) (defun dd-%sin (x) (declare (double-double-float x)) (cond ((< (abs x) (/ pi 4)) (dd-%%sin x)) (t ;; Argument reduction needed (multiple-value-bind (n reduced) (reduce-arg x) (ecase (logand n 3) (0 (dd-%%sin reduced)) (1 (dd-%%cos reduced)) (2 (- (dd-%%sin reduced))) (3 (- (dd-%%cos reduced)))))))) (declaim (ftype (function (double-double-float) double-double-float) dd-%cos)) (defun dd-%cos (x) (declare (double-double-float x)) (cond ((< (abs x) (/ pi 4)) (dd-%%cos x)) (t ;; Argument reduction needed (multiple-value-bind (n reduced) (reduce-arg x) (ecase (logand n 3) (0 (dd-%%cos reduced)) (1 (- (dd-%%sin reduced))) (2 (- (dd-%%cos reduced))) (3 (dd-%%sin reduced))))))) (declaim (ftype (function (double-double-float) double-double-float) dd-%tan)) (defun dd-%tan (x) (declare (double-double-float x)) (cond ((<= (abs x) (/ pi 4)) (dd-%%tan x 0d0)) (t ;; Argument reduction needed (multiple-value-bind (n reduced extra) (reduce-arg x) (if (evenp n) (dd-%%tan reduced extra) (- (/ (dd-%%tan reduced extra)))))))) (defun dd-%sincos (x) (declare (double-double-float x)) (cond ((< (abs x) (/ pi 4)) (values (dd-%%sin x) (dd-%%cos x))) (t ;; Argument reduction needed (multiple-value-bind (n reduced) (reduce-arg x) (case (logand n 3) (0 (values (dd-%%sin reduced) (dd-%%cos reduced))) (1 (values (dd-%%cos reduced) (- (dd-%%sin reduced)))) (2 (values (- (dd-%%sin reduced)) (- (dd-%%cos reduced)))) (3 (values (- (dd-%%cos reduced)) (dd-%%sin reduced)))))))) ;;; dd-%log2 and dd-%log10 ;;; Base 2 and base 10 logarithm. ;;; ;;; The argument is separated into its exponent and fractional ;;; parts. If the exponent is between -1 and +1, the (natural) ;;; logarithm of the fraction is approximated by ;;; ;;; log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). ;;; ;;; Otherwise, setting z = 2(x-1)/x+1), ;;; ;;; log(x) = z + z**3 R(z)/S(z). ;;; ;;; This gives the natural log. To get the base 2 and base 10 log, ;;; carefully multiply the natural log by log2(e) or log10(e) as ;;; appropriate. (let ((P (make-array 13 :element-type 'double-double-float :initial-contents '( 1.538612243596254322971797716843006400388w-6 4.998469661968096229986658302195402690910w-1 2.321125933898420063925789532045674660756w1 4.114517881637811823002128927449878962058w2 3.824952356185897735160588078446136783779w3 2.128857716871515081352991964243375186031w4 7.594356839258970405033155585486712125861w4 1.797628303815655343403735250238293741397w5 2.854829159639697837788887080758954924001w5 3.007007295140399532324943111654767187848w5 2.014652742082537582487669938141683759923w5 7.771154681358524243729929227226708890930w4 1.313572404063446165910279910527789794488w4 ))) (Q (make-array 12 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 4.839208193348159620282142911143429644326w1 9.104928120962988414618126155557301584078w2 9.147150349299596453976674231612674085381w3 5.605842085972455027590989944010492125825w4 2.248234257620569139969141618556349415120w5 6.132189329546557743179177159925690841200w5 1.158019977462989115839826904108208787040w6 1.514882452993549494932585972882995548426w6 1.347518538384329112529391120390701166528w6 7.777690340007566932935753241556479363645w5 2.626900195321832660448791748036714883242w5 3.940717212190338497730839731583397586124w4 ))) ;; Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), ;; where z = 2(x-1)/(x+1) ;; 1/sqrt(2) <= x < sqrt(2) ;; Theoretical peak relative error = 1.1e-35, ;; relative peak error spread 1.1e-9 (R (make-array 6 :element-type 'double-double-float :initial-contents '( -8.828896441624934385266096344596648080902w-1 8.057002716646055371965756206836056074715w1 -2.024301798136027039250415126250455056397w3 2.048819892795278657810231591630928516206w4 -8.977257995689735303686582344659576526998w4 1.418134209872192732479751274970992665513w5 ))) (S (make-array 6 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ -1.186359407982897997337150403816839480438w2 3.998526750980007367835804959888064681098w3 -5.748542087379434595104154610899551484314w4 4.001557694070773974936904547424676279307w5 -1.332535117259762928288745111081235577029w6 1.701761051846631278975701529965589676574w6 )))) (flet ((compute-log (x) ;; Common routine to extract the exponent and fraction from x ;; and compute the log(f). Return the exponent, the fraction, ;; and the parts of the polynomial computation that is needed ;; to finish off the final logarithm. (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (multiple-value-bind (x e) (decode-float x) (declare (type double-double-float x) (type double-float-exponent e)) (let ((z 0w0) (y 0w0)) (declare (type double-double-float z y)) (cond ((or (> e 2) (< e -2)) (cond ((< x sqrt-1/2) ;; 2*(2*x-1)/(2*x+1) (decf e) (setf z (- x 0.5w0)) (setf y (+ (* 0.5w0 z) 0.5w0))) (t ;; 2*(x-1)/(x+1) (setf z (- x 0.5w0)) (decf z 0.5w0) (setf y (+ (* 0.5w0 x) 0.5w0)))) (setf x (/ z y)) (setf z (* x x)) (setf y (* x (/ (* z (poly-eval z r)) (poly-eval-1 z s))))) (t (cond ((< x sqrt-1/2) (decf e) (setf x (- (scale-float x 1) 1))) (t (decf x))) (setf z (* x x)) (setf y (* x (/ (* z (poly-eval x p)) (poly-eval-1 x q)))) (decf y (scale-float z -1)))) (values e x y z))))) (defun dd-%log2 (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (eql x 0w0) ;; log2(+0) = -infinity (return-from dd-%log2 (/ -1 x))) (multiple-value-bind (e x y z) (compute-log x) ;; Multiply log of fraction by log2(e) and base 2 exponent by 1 ;; ;; This sequence of operations is critical (setf z (* y log2ea)) (incf z (* x log2ea)) (incf z y) (incf z x) (incf z e) z)) (defun dd-%log10 (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (eql x 0w0) ;; log2(+0) = -infinity (return-from dd-%log10 (/ -1 x))) (multiple-value-bind (e x y z) (compute-log x) ;; Multiply log of fraction by log10(e) and base 2 exponent by log10(2). ;; ;; This sequence of operations is critical. (setf z (* y l10eb)) (incf z (* x l10eb)) (incf z (* e l102b)) (incf z (* y l10ea)) (incf z (* x l10ea)) (incf z (* e l102a)) z)))) ;;; dd-%exp2 ;;; 2^x (let ((P (make-array 5 :element-type 'double-double-float :initial-contents '( 1.587171580015525194694938306936721666031w2 6.185032670011643762127954396427045467506w5 5.677513871931844661829755443994214173883w8 1.530625323728429161131811299626419117557w11 9.079594442980146270952372234833529694788w12 ))) (Q (make-array 5 :element-type 'double-double-float :initial-contents '( ;; 1.000000000000000000000000000000000000000w0 */ 1.236602014442099053716561665053645270207w4 2.186249607051644894762167991800811827835w7 1.092141473886177435056423606755843616331w10 1.490560994263653042761789432690793026977w12 2.619817175234089411411070339065679229869w13 )))) (defun dd-%exp2 (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (>= x 1024w0) (return-from dd-%exp2 (%make-double-double-float ext:double-float-positive-infinity ext:double-float-positive-infinity))) (when (<= x -1024w0) (return-from dd-%exp2 0w0)) (multiple-value-bind (n x) (floor (the (double-double-float -1024w0 1024w0) x)) (declare (type double-double-float x)) (let* ((xx (* x x)) (px (* x (poly-eval xx p)))) (setf x (/ px (- (poly-eval-1 xx q) px))) (setf x (+ 1 (scale-float x 1))) (scale-float x n))))) ;;; dd-%powil ;;; x^n where n is an integer (defun dd-%powil (x nn) (declare (type double-double-float x) (fixnum nn) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (when (zerop x) (return-from dd-%powil (cond ((zerop nn) 1w0) ((minusp nn) (%make-double-double-float ext:double-float-positive-infinity ext:double-float-positive-infinity)) (t 0w0)))) (when (zerop nn) (return-from dd-%powil 1w0)) (let ((asign 0) (sign 0) (n nn)) (declare (type (integer -1 0) asign sign) (fixnum n)) (when (minusp x) (setf asign -1) (setf x (- x))) (cond ((minusp nn) (setf sign -1) (setf n (- nn))) (t (setf sign 0) (setf n nn))) ;; Overflow detection ;; Calculate approximate log of answer (multiple-value-bind (s lx) (decode-float x) (declare (type double-double-float s) (type double-float-exponent lx)) (let ((e (* n (1- lx)))) (cond ((or (zerop e) (> e 64) (< e -64)) (setf s (/ (- s 7.0710678118654752w-1) (+ s 7.0710678118654752w-1))) (setf s (* (+ (- (* 2.9142135623730950w0 s) 0.5w0) lx) nn log2e))) (t (setf s (* loge2 e)))) (when (> s max-log) ;; Overflow. What to do? (error (intl:gettext "Overflow"))) (when (< s min-log) (return-from dd-%powil 0w0)) ;; Handle denormal answer (when (< s (- 2 max-log)) (setf x (/ x)) (setf sign 0)) ;; First bit of the power (let ((y 0w0)) (declare (type double-double-float y)) (cond ((zerop (logand n 1)) (setf y 1w0) (setf asign 0)) (t (setf y x))) (let ((w x)) (declare (type double-double-float w)) (setf n (ash n -1)) (loop while (not (zerop n)) do (setf w (* w w)) (unless (zerop (logand n 1)) (setf y (* y w))) (setf n (ash n -1)))) ;; Odd power of a negative number (unless (zerop asign) (setf y (- y))) (unless (zerop sign) (setf y (/ y))) y))))) ;;; dd-real-pow ;;; x^y, for x and y real, and real result. (defun dd-real-pow (x y) (declare (type double-double-float x y) (optimize (speed 3) (space 0) (inhibit-warnings 3))) (let ((nflg 0) (w (floor y))) ;; nflg = 1 if x < 0 raised to integer power (when (and (= w y) (< (abs w) 32768)) (return-from dd-real-pow (dd-%powil x w))) (when (<= x 0) (cond ((zerop x) (if (zerop y) ;; 0^0 (return-from dd-real-pow 1w0) ;; 0^y (return-from dd-real-pow 0w0))) (t (when (/= w y) ;; noninteger power of negative number (let ((p (the double-double-float (dd-real-pow (abs x) y))) (y*pi (* y dd-pi))) (return-from dd-real-pow (complex (* p (dd-%cos y*pi)) (* p (dd-%sin y*pi)))))) ;; For negative x, find out if the integer exponent is odd or even. (let ((w (scale-float y -1))) (declare (type double-double-float w)) (setf w (ffloor w)) (setf w (scale-float w 1)) (when (/= w y) (setf nflg 1)) (setf x (abs x)))))) (let ((z (dd-%log2 x))) (declare (type double-double-float z)) (setf z (dd-%exp2 (* y z))) (unless (zerop nflg) (setf z (- z))) z))) (defun dd-%pow (x y) (declare (type double-double-float x y)) (dd-real-pow x y)) ;; These are essentially the same as in irrat.lisp, but very slightly ;; modified to operate on double-double-floats. (defun dd-cssqs (z) ;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The ;; result is r + i*k, where k is an integer. ;; Save all FP flags (let ((x (float (realpart z) 1w0)) (y (float (imagpart z) 1w0))) ;; Would this be better handled using an exception handler to ;; catch the overflow or underflow signal? For now, we turn all ;; traps off and look at the accrued exceptions to see if any ;; signal would have been raised. ;; ;; Actually, for double-double-floats, we should probably ;; explicitly check for overflow instead of disabling the traps. ;; Why? Because instead of overflow, double-double signals ;; invalid operation. (with-float-traps-masked (:underflow :overflow :invalid) (let ((rho (+ (square x) (square y)))) (declare (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((and (or (float-nan-p rho) (float-infinity-p rho)) (or (float-infinity-p (abs x)) (float-infinity-p (abs y)))) (values (%make-double-double-float ext:double-float-positive-infinity 0d0) 0)) ((let ((threshold #.(/ least-positive-double-float double-float-epsilon)) (traps (ldb vm::float-sticky-bits (vm:floating-point-modes)))) ;; Overflow raised or (underflow raised and rho < ;; lambda/eps) (or (not (zerop (logand vm:float-overflow-trap-bit traps))) (and (not (zerop (logand vm:float-underflow-trap-bit traps))) (< rho threshold)))) ;; If we're here, neither x nor y are infinity and at ;; least one is non-zero.. Thus logb returns a nice ;; integer. (let ((k (- (logb-finite (max (abs x) (abs y)))))) (values (+ (square (scalb x k)) (square (scalb y k))) (- k)))) (t (values rho 0))))))) (defun dd-complex-sqrt (z) _N"Principle square root of Z Z may be any number, but the result is always a complex." (declare (number z)) (multiple-value-bind (rho k) (dd-cssqs z) (declare (type (or (member 0w0) (double-double-float 0w0)) rho) (type fixnum k)) (let ((x (float (realpart z) 1.0w0)) (y (float (imagpart z) 1.0w0)) (eta 0w0) (nu 0w0)) (declare (type double-double-float x y eta nu)) (locally ;; space 0 to get maybe-inline functions inlined. (declare (optimize (speed 3) (space 0) (inhibit-warnings 3))) (if (not (float-nan-p x)) (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) (cond ((oddp k) (setf k (ash k -1))) (t (setf k (1- (ash k -1))) (setf rho (+ rho rho)))) (setf rho (scalb (sqrt rho) k)) (setf eta rho) (setf nu y) (when (/= rho 0d0) (when (not (float-infinity-p (abs nu))) (setf nu (/ (/ nu rho) 2d0))) (when (< x 0d0) (setf eta (abs nu)) (setf nu (float-sign y rho)))) (complex eta nu))))) (defun dd-complex-log-scaled (z j) _N"Compute log(2^j*z). This is for use with J /= 0 only when |z| is huge." (declare (number z) (fixnum j)) ;; The constants t0, t1, t2 should be evaluated to machine ;; precision. In addition, Kahan says the accuracy of log1p ;; influences the choices of these constants but doesn't say how to ;; choose them. We'll just assume his choices matches our ;; implementation of log1p. (let ((t0 #.(/ 1 (sqrt 2.0w0))) (t1 1.2w0) (t2 3w0) (ln2 #.(log 2w0)) (x (float (realpart z) 1.0w0)) (y (float (imagpart z) 1.0w0))) (multiple-value-bind (rho k) (dd-cssqs z) (declare (optimize (speed 3) (inhibit-warnings 3))) (let ((beta (max (abs x) (abs y))) (theta (min (abs x) (abs y)))) (complex (if (and (zerop k) (< t0 beta) (or (<= beta t1) (< rho t2))) (/ (dd-%log1p (+ (* (- beta 1.0d0) (+ beta 1.0d0)) (* theta theta))) 2d0) (+ (/ (log rho) 2d0) (* (+ k j) ln2))) (atan y x)))))) (defun dd-complex-log (z) _N"Log of Z = log |Z| + i * arg Z Z may be any number, but the result is always a complex." (declare (number z)) (dd-complex-log-scaled z 0)) ;; Let us note the following "strange" behavior. atanh 1.0d0 is ;; +infinity, but the following code returns approx 176 + i*pi/4. The ;; reason for the imaginary part is caused by the fact that arg i*y is ;; never 0 since we have positive and negative zeroes. (defun dd-complex-atanh (z) _N"Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) (if (realp z) ;; See complex-atanh for why we do this. (dd-complex-atanh (complex z (- (* 0.0 z)))) (let* ( ;; Constants (theta (/ (sqrt most-positive-double-float) 4.0w0)) (rho (/ 4.0w0 (sqrt most-positive-double-float))) (half-pi dd-pi/2) (rp (float (realpart z) 1.0w0)) (beta (float-sign rp 1.0w0)) (x (* beta rp)) (y (* beta (- (float (imagpart z) 1.0w0)))) (eta 0.0w0) (nu 0.0w0)) ;; Shouldn't need this declare. (declare (double-double-float x y)) (locally (declare (optimize (speed 3) (inhibit-warnings 3))) (cond ((or (> x theta) (> (abs y) theta)) ;; To avoid overflow... (setf nu (float-sign y half-pi)) ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), ;; which can cause overflow. Arrange this computation so ;; that it won't overflow. (setf eta (let* ((x-bigger (> x (abs y))) (r (if x-bigger (/ y x) (/ x y))) (d (+ 1.0d0 (* r r)))) (if x-bigger (/ (/ x) d) (/ (/ r y) d))))) ((= x 1.0w0) ;; Should this be changed so that if y is zero, eta is set ;; to +infinity instead of approx 176? In any case ;; tanh(176) is 1.0d0 within working precision. (let ((t1 (+ 4w0 (square y))) (t2 (+ (abs y) rho))) (setf eta (dd-%log (/ (sqrt (sqrt t1)) (sqrt t2)))) (setf nu (* 0.5d0 (float-sign y (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) (t (let ((t1 (+ (abs y) rho))) ;; Normal case using log1p(x) = log(1 + x) (setf eta (* 0.25d0 (dd-%log1p (/ (* 4.0d0 x) (+ (square (- 1.0d0 x)) (square t1)))))) (setf nu (* 0.5d0 (dd-%atan2 (* 2.0d0 y) (- (* (- 1.0d0 x) (+ 1.0d0 x)) (square t1)))))))) (complex (* beta eta) (- (* beta nu))))))) (defun dd-complex-tanh (z) _N"Compute tanh z = sinh z / cosh z" (declare (number z)) (let ((x (float (realpart z) 1.0w0)) (y (float (imagpart z) 1.0w0))) (locally ;; space 0 to get maybe-inline functions inlined (declare (optimize (speed 3) (space 0) (inhibit-warnings 3))) (cond ((> (abs x) #-(or linux hpux) #.(/ (%asinh most-positive-double-float) 4d0) ;; This is more accurate under linux. #+(or linux hpux) #.(/ (+ (%log 2.0d0) (%log most-positive-double-float)) 4d0)) (complex (float-sign x) (float-sign y))) (t (let* ((tv (dd-%tan y)) (beta (+ 1.0d0 (* tv tv))) (s (sinh x)) (rho (sqrt (+ 1.0d0 (* s s))))) (if (float-infinity-p (abs tv)) (complex (/ rho s) (/ tv)) (let ((den (+ 1.0d0 (* beta s s)))) (complex (/ (* beta rho s) den) (/ tv den)))))))))) ;; Kahan says we should only compute the parts needed. Thus, the ;; realpart's below should only compute the real part, not the whole ;; complex expression. Doing this can be important because we may get ;; spurious signals that occur in the part that we are not using. ;; ;; However, we take a pragmatic approach and just use the whole ;; expression. ;; NOTE: The formula given by Kahan is somewhat ambiguous in whether ;; it's the conjugate of the square root or the square root of the ;; conjugate. This needs to be checked. ;; I checked. It doesn't matter because (conjugate (sqrt z)) is the ;; same as (sqrt (conjugate z)) for all z. This follows because ;; ;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z). ;; ;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z) ;; ;; and these two expressions are equal if and only if arg conj z = ;; -arg z, which is clearly true for all z. ;; NOTE: The rules of Common Lisp says that if you mix a real with a ;; complex, the real is converted to a complex before performing the ;; operation. However, Kahan says in this paper (pg 176): ;; ;; (iii) Careless handling can turn infinity or the sign of zero into ;; misinformation that subsequently disappears leaving behind ;; only a plausible but incorrect result. That is why compilers ;; must not transform z-1 into z-(1+i*0), as we have seen above, ;; nor -(-x-x^2) into (x+x^2), as we shall see below, lest a ;; subsequent logarithm or square root produce a non-zero ;; imaginary part whose sign is opposite to what was intended. ;; ;; The interesting examples are too long and complicated to reproduce ;; here. We refer the reader to his paper. ;; ;; The functions below are intended to handle the cases where a real ;; is mixed with a complex and we don't want CL complex contagion to ;; occur.. (declaim (inline 1+z 1-z z-1 z+1)) (defun dd-1+z (z) (complex (+ 1 (realpart z)) (imagpart z))) (defun dd-1-z (z) (complex (- 1 (realpart z)) (- (imagpart z)))) (defun dd-z-1 (z) (complex (- (realpart z) 1) (imagpart z))) (defun dd-z+1 (z) (complex (+ (realpart z) 1) (imagpart z))) (defun dd-complex-acos (z) _N"Compute acos z = pi/2 - asin z Z may be any number, but the result is always a complex." (declare (number z)) (if (and (realp z) (> z 1)) ;; acos is continuous in quadrant IV in this case. (complex-acos (complex z -0f0)) (let ((sqrt-1+z (complex-sqrt (1+z z))) (sqrt-1-z (complex-sqrt (1-z z)))) (cond ((zerop (realpart sqrt-1+z)) ;; Same as below, but we compute atan ourselves (because we ;; have atan +/- infinity). (complex (if (minusp (float-sign (* (realpart sqrt-1-z) (realpart sqrt-1+z)))) (- dd-pi) dd-pi) (asinh (imagpart (* (conjugate sqrt-1+z) sqrt-1-z))))) (t (complex (* 2 (atan (/ (realpart sqrt-1-z) (realpart sqrt-1+z)))) (asinh (imagpart (* (conjugate sqrt-1+z) sqrt-1-z))))))))) (defun dd-complex-acosh (z) _N"Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) Z may be any number, but the result is always a complex." (declare (number z)) (let* ((sqrt-z-1 (complex-sqrt (z-1 z))) (sqrt-z+1 (complex-sqrt (z+1 z)))) ;; We need to handle the case where real part of sqrt-z+1 is zero, ;; because division by zero with double-double-floats doesn't ;; produce infinity. (cond ((zerop (realpart sqrt-z+1)) ;; Same as below, but we compute atan ourselves (because we ;; have atan +/- infinity). (complex (asinh (realpart (* (conjugate sqrt-z-1) sqrt-z+1))) (if (minusp (float-sign (* (imagpart sqrt-z-1) (realpart sqrt-z+1)))) (- dd-pi) dd-pi))) (t (complex (asinh (realpart (* (conjugate sqrt-z-1) sqrt-z+1))) (* 2 (atan (/ (imagpart sqrt-z-1) (realpart sqrt-z+1))))))))) (defun dd-complex-asin (z) _N"Compute asin z = -i*log(i*z + sqrt(1-z^2)) Z may be any number, but the result is always a complex." (declare (number z)) (cond ((and (realp z) (> z 1)) (dd-complex-asin (complex z -0w0))) (t (let* ((sqrt-1-z (complex-sqrt (1-z z))) (sqrt-1+z (complex-sqrt (1+z z))) (den (realpart (* sqrt-1-z sqrt-1+z)))) (cond ((zerop den) ;; Like below but we handle atan part ourselves. ;; Must be sure to take into account the sign of ;; (realpart z) and den! (complex (if (minusp (* (float-sign (realpart z)) (float-sign den))) (- dd-pi/2) dd-pi/2) (asinh (imagpart (* (conjugate sqrt-1-z) sqrt-1+z))))) (t (with-float-traps-masked (:divide-by-zero) ;; We get a invalid operation here when z is real and |z| > 1. (complex (atan (/ (realpart z) den)) (asinh (imagpart (* (conjugate sqrt-1-z) sqrt-1+z))))))))))) (defun dd-complex-asinh (z) _N"Compute asinh z = log(z + sqrt(1 + z*z)) Z may be any number, but the result is always a complex." (declare (number z)) ;; asinh z = -i * asin (i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-asin iz))) (complex (imagpart result) (- (realpart result))))) (defun dd-complex-atan (z) _N"Compute atan z = (log(1+i*z) - log(1-i*z))/(2*i) Z may be any number, but the result is always a complex." (declare (number z)) ;; atan z = -i * atanh (i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-atanh iz))) (complex (imagpart result) (- (realpart result))))) (defun dd-complex-tan (z) _N"Compute tan z = -i * tanh(i * z) Z may be any number, but the result is always a complex." (declare (number z)) ;; tan z = -i * tanh(i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-tanh iz))) (complex (imagpart result) (- (realpart result))))) cmucl-21a/src/code/irrat.lisp000066400000000000000000001573521260377556400163110ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/irrat.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains all the irrational functions. Actually, most of the ;;; work is done by calling out to C... ;;; ;;; Author: William Lott. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") ;;;; Random constants, utility functions, and macros. (defconstant pi 3.14159265358979323846264338327950288419716939937511L0) ;(defconstant e 2.71828182845904523536028747135266249775724709369996L0) ;;; Make these INLINE, since the call to C is at least as compact as a Lisp ;;; call, and saves number consing to boot. ;;; (defmacro def-math-rtn (name num-args) (multiple-value-bind (c-name lisp-name) (if (listp name) (values (first name) (second name)) (values name (intern (concatenate 'simple-string "%" (string-upcase name))))) `(progn (declaim (inline ,lisp-name)) (export ',lisp-name) (alien:def-alien-routine (,c-name ,lisp-name) double-float ,@(let ((results nil)) (dotimes (i num-args (nreverse results)) (push (list (intern (format nil "ARG-~D" i)) 'double-float) results))))))) (eval-when (compile load eval) (defun handle-reals (function var) `((((foreach fixnum single-float bignum ratio)) (coerce (,function (coerce ,var 'double-float)) 'single-float)) ((double-float) (,function ,var)) #+double-double ((double-double-float) (,(symbolicate "DD-" function) ,var)))) ); eval-when (compile load eval) ;;;; Stubs for the Unix math library. ;;; Please refer to the Unix man pages for details about these routines. ;;; Trigonometric. (def-math-rtn ("fdlibm_sin" %sin) 1) (def-math-rtn ("fdlibm_cos" %cos) 1) (def-math-rtn ("fdlibm_tan" %tan) 1) (def-math-rtn ("fdlibm_atan" %atan) 1) (def-math-rtn ("__ieee754_atan2" %atan2) 2) (def-math-rtn ("__ieee754_asin" %asin) 1) (def-math-rtn ("__ieee754_acos" %acos) 1) (def-math-rtn ("__ieee754_sinh" %sinh) 1) (def-math-rtn ("__ieee754_cosh" %cosh) 1) (def-math-rtn ("fdlibm_tanh" %tanh) 1) (def-math-rtn ("fdlibm_asinh" %asinh) 1) (def-math-rtn ("__ieee754_acosh" %acosh) 1) (def-math-rtn ("__ieee754_atanh" %atanh) 1) ;;; Exponential and Logarithmic. (def-math-rtn ("__ieee754_exp" %exp) 1) (def-math-rtn ("__ieee754_log" %log) 1) (def-math-rtn ("__ieee754_log10" %log10) 1) (def-math-rtn ("cmucl_log2" %log2) 1) (def-math-rtn ("__ieee754_pow" %pow) 2) #-(or x86 sparc-v7 sparc-v8 sparc-v9) (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) (def-math-rtn ("fdlibm_log1p" %log1p) 1) (def-math-rtn ("fdlibm_expm1" %expm1) 1) (declaim (inline %scalbn)) (export '%scalbn) (alien:def-alien-routine ("fdlibm_scalbn" %scalbn) c-call:double (x double-float) (n c-call:int)) ;; These are needed for use by byte-compiled files. But don't use ;; these with sse2 since we don't support using the x87 instructions ;; here. #+(and x86 (not sse2)) (progn #+nil (defun %sin (x) (declare (double-float x) (values double-float)) (%sin x)) (defun %sin-quick (x) (declare (double-float x) (values double-float)) (%sin-quick x)) #+nil (defun %cos (x) (declare (double-float x) (values double-float)) (%cos x)) (defun %cos-quick (x) (declare (double-float x) (values double-float)) (%cos-quick x)) #+nil (defun %tan (x) (declare (double-float x) (values double-float)) (%tan x)) (defun %tan-quick (x) (declare (double-float x) (values double-float)) (%tan-quick x)) (defun %atan (x) (declare (double-float x) (values double-float)) (%atan x)) (defun %atan2 (x y) (declare (double-float x y) (values double-float)) (%atan2 x y)) (defun %exp (x) (declare (double-float x) (values double-float)) (%exp x)) (defun %log (x) (declare (double-float x) (values double-float)) (%log x)) (defun %log10 (x) (declare (double-float x) (values double-float)) (%log10 x)) #+nil ;; notyet (defun %pow (x y) (declare (type (double-float 0d0) x) (double-float y) (values (double-float 0d0))) (%pow x y)) (defun %sqrt (x) (declare (double-float x) (values double-float)) (%sqrt x)) (defun %scalbn (f ex) (declare (double-float f) (type (signed-byte 32) ex) (values double-float)) (%scalbn f ex)) (defun %scalb (f ex) (declare (double-float f ex) (values double-float)) (%scalb f ex)) (defun %logb (x) (declare (double-float x) (values double-float)) (%logb x)) (defun %log1p (x) (declare (double-float x) (values double-float)) (%log1p x)) ) ; progn ;; As above for x86. It also seems to be needed to handle ;; constant-folding in the compiler. #+(or sparc (and x86 sse2)) (progn (defun %sqrt (x) (declare (double-float x) (values double-float)) (%sqrt x)) ) ;; Slightly simplified interface to __ieee754_rem_pio2, but instead of ;; needing to pass an array in, the output array is broken up into two ;; output values instead. This is easier for the user, and we don't ;; have to wrap calls with without-gcing. (declaim (inline %ieee754-rem-pi/2)) (export '%ieee754-rem-pi/2) (alien:def-alien-routine ("ieee754_rem_pio2" %ieee754-rem-pi/2) c-call:int (x double-float) (y0 double-float :out) (y1 double-float :out)) (declaim (inline %%sincos)) (alien:def-alien-routine ("lisp_sincos" %%sincos) c-call:void (x double-float) (s double-float :out) (c double-float :out)) (declaim (inline %sincos)) (export '%sincos) (defun %sincos (x) (declare (double-float x)) (multiple-value-bind (ign s c) (%%sincos x) (declare (ignore ign)) (values s c))) ;;;; Power functions. (defun exp (number) "Return e raised to the power NUMBER." (number-dispatch ((number number)) (handle-reals %exp number) ((complex) (* (exp (realpart number)) (cis (imagpart number)))))) ;;; INTEXP -- Handle the rational base, integer power case. (defparameter *intexp-maximum-exponent* 10000) (define-condition intexp-limit-error (error) ((base :initarg :base :reader intexp-base) (power :initarg :power :reader intexp-power)) (:report (lambda (condition stream) (format stream (intl:gettext "The absolute value of ~S exceeds limit ~S.") (intexp-power condition) *intexp-maximum-exponent*)))) ;;; This function precisely calculates base raised to an integral power. It ;;; separates the cases by the sign of power, for efficiency reasons, as powers ;;; can be calculated more efficiently if power is a positive integer. Values ;;; of power are calculated as positive integers, and inverted if negative. ;;; (defun intexp (base power) ;; Handle the special case of 1^power and (-1)^power. Maxima ;; sometimes does this, and there's no need to cause a continuable ;; error in this case. (when (eql base 1) (return-from intexp base)) (when (eql base -1) (return-from intexp (if (oddp power) -1 1))) (when (> (abs power) *intexp-maximum-exponent*) ;; Allow user the option to continue with calculation, possibly ;; increasing the limit to the given power. (restart-case (error 'intexp-limit-error :base base :power power) (continue () :report (lambda (stream) (write-string (intl:gettext "Continue with calculation") stream))) (new-limit () :report (lambda (stream) (write-string (intl:gettext "Continue with calculation, update limit") stream)) (setq *intexp-maximum-exponent* (abs power))))) (cond ((minusp power) (/ (intexp base (- power)))) ((eql base 2) (ash 1 power)) (t (do ((nextn (ash power -1) (ash power -1)) (total (if (oddp power) base 1) (if (oddp power) (* base total) total))) ((zerop nextn) total) (setq base (* base base)) (setq power nextn))))) ;;; EXPT -- Public ;;; ;;; If an integer power of a rational, use INTEXP above. Otherwise, do ;;; floating point stuff. If both args are real, we try %POW right off, ;;; assuming it will return 0 if the result may be complex. If so, we call ;;; COMPLEX-POW which directly computes the complex result. We also separate ;;; the complex-real and real-complex cases from the general complex case. ;;; (defun expt (base power) "Returns BASE raised to the POWER." (if (zerop power) ;; CLHS says that if the power is 0, the result is 1, subject to ;; numeric contagion. But what happens if base is infinity or ;; NaN? Do we silently return 1? For now, I think we should ;; signal an error if the FP modes say so. (let ((result (1+ (* base power)))) ;; If we get an NaN here, that means base*power above didn't ;; produce 0 and FP traps were disabled, so we handle that ;; here. Should this be a continuable restart? (if (and (floatp result) (float-nan-p result)) (float 1 result) result)) (labels (;; determine if the double float is an integer. ;; 0 - not an integer ;; 1 - an odd int ;; 2 - an even int (isint (ihi lo) (declare (type (unsigned-byte 31) ihi) (type (unsigned-byte 32) lo) (optimize (speed 3) (safety 0))) (let ((isint 0)) (declare (type fixnum isint)) (cond ((>= ihi #x43400000) ; exponent >= 53 (setq isint 2)) ((>= ihi #x3ff00000) (let ((k (- (ash ihi -20) #x3ff))) ; exponent (declare (type (mod 53) k)) (cond ((> k 20) (let* ((shift (- 52 k)) (j (logand (ash lo (- shift)))) (j2 (ash j shift))) (declare (type (mod 32) shift) (type (unsigned-byte 32) j j2)) (when (= j2 lo) (setq isint (- 2 (logand j 1)))))) ((= lo 0) (let* ((shift (- 20 k)) (j (ash ihi (- shift))) (j2 (ash j shift))) (declare (type (mod 32) shift) (type (unsigned-byte 31) j j2)) (when (= j2 ihi) (setq isint (- 2 (logand j 1)))))))))) isint)) (real-expt (x y rtype) (let ((x (coerce x 'double-float)) (y (coerce y 'double-float))) (declare (double-float x y)) (let* ((x-hi (kernel:double-float-high-bits x)) (x-lo (kernel:double-float-low-bits x)) (x-ihi (logand x-hi #x7fffffff)) (y-hi (kernel:double-float-high-bits y)) (y-lo (kernel:double-float-low-bits y)) (y-ihi (logand y-hi #x7fffffff))) (declare (type (signed-byte 32) x-hi y-hi) (type (unsigned-byte 31) x-ihi y-ihi) (type (unsigned-byte 32) x-lo y-lo)) ;; y==zero: x**0 = 1 (when (zerop (logior y-ihi y-lo)) (return-from real-expt (coerce 1d0 rtype))) ;; +-NaN return x+y (when (or (> x-ihi #x7ff00000) (and (= x-ihi #x7ff00000) (/= x-lo 0)) (> y-ihi #x7ff00000) (and (= y-ihi #x7ff00000) (/= y-lo 0))) (return-from real-expt (coerce (+ x y) rtype))) (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0))) (declare (type fixnum yisint)) ;; special value of y (when (and (zerop y-lo) (= y-ihi #x7ff00000)) ;; y is +-inf (return-from real-expt (cond ((and (= x-ihi #x3ff00000) (zerop x-lo)) ;; +-1**inf is NaN (coerce (- y y) rtype)) ((>= x-ihi #x3ff00000) ;; (|x|>1)**+-inf = inf,0 (if (>= y-hi 0) (coerce y rtype) (coerce 0 rtype))) (t ;; (|x|<1)**-,+inf = inf,0 (if (< y-hi 0) (coerce (- y) rtype) (coerce 0 rtype)))))) (let ((abs-x (abs x))) (declare (double-float abs-x)) ;; special value of x (when (and (zerop x-lo) (or (= x-ihi #x7ff00000) (zerop x-ihi) (= x-ihi #x3ff00000))) ;; x is +-0,+-inf,+-1 (let ((z (if (< y-hi 0) (/ 1 abs-x) ; z = (1/|x|) abs-x))) (declare (double-float z)) (when (< x-hi 0) (cond ((and (= x-ihi #x3ff00000) (zerop yisint)) ;; (-1)**non-int (let ((y*pi (* y pi))) (declare (double-float y*pi)) (return-from real-expt (complex (coerce (%cos y*pi) rtype) (coerce (%sin y*pi) rtype))))) ((= yisint 1) ;; (x<0)**odd = -(|x|**odd) (setq z (- z))))) (return-from real-expt (coerce z rtype)))) (if (>= x-hi 0) ;; x>0 (coerce (kernel::%pow x y) rtype) ;; x<0 (let ((pow (kernel::%pow abs-x y))) (declare (double-float pow)) (case yisint (1 ; Odd (coerce (* -1d0 pow) rtype)) (2 ; Even (coerce pow rtype)) (t ; Non-integer (let ((y*pi (* y pi))) (declare (double-float y*pi)) (complex (coerce (* pow (%cos y*pi)) rtype) (coerce (* pow (%sin y*pi)) rtype)))))))))))) (expt-xfrm (b p) ;; Apply the same transformation as in the deftransform ;; for expt in compiler/srctran.lisp. Only call this ;; if B is more contagious than P. Otherwise, the type ;; of the result will be wrong which will confuse the ;; compiler! Return NIL if the transform can't be ;; applied. (cond ((= p 2) (* b b)) ((= p -2) (/ (* b b))) ((= p 3) (* b b b)) ((= p -3) (/ (* b b b))) ((= p 1/2) (sqrt b)) ((= p -1/2) (/ (sqrt b))) (t nil)))) ;; This is really messy and should be cleaned up. The easiest ;; way to see if we're doing what we should is the macroexpand ;; the number-dispatch and check each branch. ;; ;; We try to apply the rule of float precision contagion (CLHS ;; 12.1.4.4): the result has the same precision has the most ;; precise argument. (number-dispatch ((base number) (power number)) (((foreach fixnum (or bignum ratio) (complex rational)) integer) (intexp base power)) (((foreach single-float double-float) rational) (or (expt-xfrm base power) (real-expt base power '(dispatch-type base)))) (((foreach fixnum (or bignum ratio) single-float) (foreach ratio single-float)) (or (expt-xfrm (coerce base 'single-float) power) (real-expt base power 'single-float))) (((foreach fixnum (or bignum ratio) single-float double-float) double-float) (or (expt-xfrm (coerce base 'double-float) power) (real-expt base power 'double-float))) ((double-float single-float) (or (expt-xfrm (coerce base 'double-float) power) (real-expt base power 'double-float))) #+double-double (((foreach fixnum (or bignum ratio) single-float double-float double-double-float) double-double-float) (or (expt-xfrm (coerce base 'double-double-float) power) (dd-%pow (coerce base 'double-double-float) power))) #+double-double ((double-double-float (foreach fixnum (or bignum ratio) single-float double-float)) (or (expt-xfrm base power) (dd-%pow base (coerce power 'double-double-float)))) (((foreach (complex rational) (complex single-float) (complex double-float) #+double-double (complex double-double-float)) rational) (or (expt-xfrm base power) (* (expt (abs base) power) (cis (* power (phase base)))))) #+double-double ((double-double-float complex) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (* (log2 base 1w0) (log 2w0)))))) (((foreach fixnum (or bignum ratio) single-float double-float) (foreach (complex double-float))) ;; Result should have double-float accuracy. Use log2 in ;; case the base won't fit in a double-float. (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (* (log2 base) (log 2d0)))))) ((double-float (foreach (complex rational) (complex single-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (log base))))) #+double-double (((foreach fixnum (or bignum ratio) single-float double-float) (foreach (complex double-double-float))) ;; Result should have double-double-float accuracy. Use log2 ;; in case the base won't fit in a double-float. (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (* (log2 base 1w0) (log 2w0)))))) (((foreach fixnum (or bignum ratio) single-float) (foreach (complex single-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (log base))))) (((foreach (complex rational) (complex single-float)) (foreach single-float (complex single-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm (coerce base '(complex single-float)) power) (exp (* power (log base)))))) (((foreach (complex rational) (complex single-float)) (foreach double-float (complex double-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm (coerce base '(complex double-float)) power) (exp (* power (log (coerce base '(complex double-float)))))))) #+double-double (((foreach (complex rational) (complex single-float)) (foreach double-double-float (complex double-double-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm (coerce base '(complex double-double-float)) power) (exp (* power (log (coerce base '(complex double-double-float)))))))) (((foreach (complex double-float)) (foreach single-float double-float (complex single-float) (complex double-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm base power) (exp (* power (log base)))))) #+double-double (((foreach (complex double-float)) (foreach double-double-float (complex double-double-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm (coerce base '(complex double-double-float)) power) (exp (* power (log (coerce base '(complex double-double-float)))))))) #+double-double (((foreach (complex double-double-float)) (foreach float (complex float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm base power) (exp (* power (log base)))))))))) ;; Log base 2 of a real number. The result is a either a double-float ;; or double-double-float number (real or complex, as appropriate), ;; depending on the type of FLOAT-TYPE. (defun log2 (x &optional (float-type 1d0)) (labels ((log-of-2 (f) ;; log(2), with the precision specified by the type of F (number-dispatch ((f real)) ((double-float) #.(log 2d0)) #+double-double ((double-double-float) #.(log 2w0)))) (log-2-pi (f) ;; log(pi), with the precision specified by the type of F (number-dispatch ((f real)) ((double-float) #.(/ pi (log 2d0))) #+double-double ((double-double-float) #.(/ dd-pi (log 2w0))))) (log1p (x) ;; log(1+x), with the precision specified by the type of ;; X (number-dispatch ((x real)) (((foreach single-float double-float)) (%log1p (float x 1d0))) #+double-double ((double-double-float) (dd-%log1p x)))) (log2-bignum (bignum) ;; Write x = 2^n*f where 1/2 < f <= 1. Then log2(x) = n ;; + log2(f). ;; ;; So we grab the top few bits of x and scale that ;; appropriately, take the log of it and add it to n. ;; ;; Return n and log2(f) separately. (if (minusp bignum) (multiple-value-bind (n frac) (log2-bignum (abs bignum)) (values n (complex frac (log-2-pi float-type)))) (let ((n (integer-length bignum)) (float-bits (float-digits float-type))) (if (< n float-bits) (values 0 (log (float bignum float-type) (float 2 float-type))) (let ((exp (min float-bits n)) (f (ldb (byte float-bits (max 0 (- n float-bits))) bignum))) (values n (log (scale-float (float f float-type) (- exp)) (float 2 float-type))))))))) (etypecase x (float (multiple-value-bind (f e s) (decode-float x) ;; If x = 2^e*f then log2(x) = e + log2(f) = e + ;; log(f)/log(2). Accuracy could be improved some since this ;; has 2 rounding operations instead of just 1 for ;; log(x)/log(2). (let ((log2 (+ e (/ (log (float f float-type)) (log-of-2 float-type))))) (if (minusp s) (complex log2 (log-2-pi float-type)) log2)))) (ratio (let ((top (numerator x)) (bot (denominator x))) ;; If the number of bits in the numerator and ;; denominator are different, just use the fact ;; log(x/y) = log(x) - log(y). But to preserve ;; accuracy, we actually do ;; (log2(x)-log2(y))/log2(e)). ;; ;; However, if the numerator and denominator have the ;; same number of bits, implying the quotient is near ;; one, we use log1p(x) = log(1+x). Since the number is ;; rational, we don't lose precision subtracting 1 from ;; it, and converting it to double-float is accurate. (if (= (integer-length top) (integer-length bot)) (let ((log-abs (/ (log1p (float (- (abs x) 1) float-type)) (log-of-2 float-type)))) (if (minusp x) (complex log-abs (log-2-pi float-type)) log-abs)) (multiple-value-bind (top-n top-frac) (log2-bignum top) (multiple-value-bind (bot-n bot-frac) (log2-bignum bot) (+ (- top-n bot-n) (- top-frac bot-frac))))))) (integer (multiple-value-bind (n frac) (log2-bignum x) (+ n frac)))))) ;; Handle the case where number could be so large that it doesn't fit ;; in a double-float. (defun log10 (number &optional (float-type 1d0)) (let ((d (ignore-errors (float number 1d0)))) (cond (d ;; Number fits in a double, so it's easy (float (%log10 d) float-type)) (t ;; Number doesn't fit in a double. Do it the hard way using ;; log2. This should be done more accurately. (float (/ (log2 number) (log2 10)) float-type))))) (defun log (number &optional (base nil base-p)) "Return the logarithm of NUMBER in the base BASE, which defaults to e." (if base-p (cond ((zerop base) ;; ANSI spec base) ((and (realp number) (realp base)) (cond ((and (= base 2) ;;(floatp number) (or (plusp number) (eql number 0.0) (eql number 0d0) #+double-double (eql number 0w0))) ;; Do the same thing as the deftranform does for log ;; base 2 and 10 for non-negative arguments: handle ;; the case where number > 0 or equal to +0. (number-dispatch ((number real) (base real)) ((double-float (foreach integer ratio single-float double-float)) (%log2 number)) ((single-float double-float) (%log2 (float number 1d0))) ((single-float (foreach integer ratio single-float)) (float (%log2 (float number 1d0)) 1f0)) (((foreach integer ratio) (foreach integer ratio single-float)) (float (log2 number) 1f0)) (((foreach integer ratio) double-float) (log2 number)) #+double-double (((foreach single-float double-float) double-double-float) (dd-%log2 (float number 1w0))) #+double-double (((foreach integer ratio) double-double-float) (log2 number 1w0)) #+double-double ((double-double-float (foreach integer ratio single-float double-float double-double-float)) (dd-%log2 number)))) ((and (= base 10) ;;(floatp number) (or (plusp number) (eql number 0.0) (eql number 0d0))) ;; Do the same thing as the deftranform does for ;; log base 2 and 10 for non-negative arguments. (number-dispatch ((number real) (base real)) ((double-float (foreach integer ratio single-float double-float)) (%log10 number)) ((single-float double-float) (%log10 (float number 1d0))) ((single-float (foreach integer ratio single-float)) (float (%log10 (float number 1d0)) 1f0)) (((foreach integer ratio) (foreach integer ratio single-float)) (log10 number 1f0)) (((foreach integer ratio) double-float) (log10 number 1d0)) #+double-double (((foreach integer ratio) ext:double-double-float) (log10 number 1w0)) #+double-double (((foreach single-float double-float) ext:double-double-float) (dd-%log10 (float number 1w0))) #+double-double ((double-double-float (foreach integer ratio single-float double-float double-double-float)) (dd-%log10 number)))) (t ;; CLHS 12.1.4.1 says ;; ;; When rationals and floats are combined by a ;; numerical function, the rational is first converted ;; to a float of the same format. ;; ;; So assume this applies to floats as well convert all ;; numbers to the largest float format before computing ;; the log. ;; ;; This makes (log 17 10.0) = (log 17.0 10) and so on. (number-dispatch ((number real) (base real)) ((double-float (foreach double-float single-float)) (/ (log2 number) (log2 base))) (((foreach fixnum bignum ratio) (foreach fixnum bignum ratio single-float)) (let* ((result (/ (log2 number) (log2 base)))) ;; Figure out the right result type (if (realp result) (coerce result 'single-float) (coerce result '(complex single-float))))) (((foreach fixnum bignum ratio) double-float) (/ (log2 number) (log2 base))) ((single-float (foreach fixnum bignum ratio)) (let* ((result (/ (log2 number) (log2 base)))) ;; Figure out the right result type (if (realp result) (coerce result 'single-float) (coerce result '(complex single-float))))) ((double-float (foreach fixnum bignum ratio)) (/ (log2 number) (log2 base))) ((single-float double-float) (/ (log (coerce number 'double-float)) (log base))) #+double-double ((double-double-float (foreach fixnum bignum ratio)) ;; Use log2 in case the base is so large that it ;; won't fit in a float. (/ (log2 number 1w0) (log2 base 1w0))) #+double-double ((double-double-float (foreach double-double-float double-float single-float)) (/ (log number) (log (coerce base 'double-double-float)))) #+double-double (((foreach fixnum bignum ratio) double-double-float) (/ (log2 number 1w0) (log2 base 1w0))) #+double-double (((foreach double-float single-float) double-double-float) (/ (log (coerce number 'double-double-float)) (log base))) (((foreach single-float) (foreach single-float)) ;; Converting everything to double-float helps the ;; cases like (log 17 10) = (/ (log 17) (log 10)). ;; This is usually handled above, but if we compute (/ ;; (log 17) (log 10)), we get a slightly different ;; answer due to roundoff. This makes it a bit more ;; consistent. ;; ;; FIXME: This probably needs more work. (let ((result (/ (log (float number 1d0)) (log (float base 1d0))))) (if (realp result) (coerce result 'single-float) (coerce result '(complex single-float))))))))) (t ;; FIXME: This probably needs some work as well. (/ (log number) (log base)))) (number-dispatch ((number number)) (((foreach fixnum bignum)) (if (minusp number) (complex (coerce (log (- number)) 'single-float) (coerce pi 'single-float)) (coerce (/ (log2 number) #.(log (exp 1d0) 2d0)) 'single-float))) ((ratio) (if (minusp number) (complex (coerce (log (- number)) 'single-float) (coerce pi 'single-float)) ;; What happens when the ratio is close to 1? We need to ;; be careful to preserve accuracy. (let ((top (numerator number)) (bot (denominator number))) ;; If the number of bits in the numerator and ;; denominator are different, just use the fact ;; log(x/y) = log(x) - log(y). But to preserve ;; accuracy, we actually do ;; (log2(x)-log2(y))/log2(e)). ;; ;; However, if the numerator and denominator have the ;; same number of bits, implying the quotient is near ;; one, we use log1p(x) = log(1+x). Since the number is ;; rational, we don't lose precision subtracting 1 from ;; it, and converting it to double-float is accurate. (if (= (integer-length top) (integer-length bot)) (coerce (%log1p (coerce (- number 1) 'double-float)) 'single-float) (coerce (/ (- (log2 top) (log2 bot)) #.(log (exp 1d0) 2d0)) 'single-float))))) (((foreach single-float double-float)) ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)? ;; Since this doesn't seem to be an implementation issue ;; I (pw) take the Kahan result. (if (< (float-sign number) (coerce 0 '(dispatch-type number))) (complex (log (- number)) (coerce pi '(dispatch-type number))) (coerce (%log (coerce number 'double-float)) '(dispatch-type number)))) #+double-double ((double-double-float) (let ((hi (kernel:double-double-hi number))) (if (< (float-sign hi) 0d0) (complex (dd-%log (- number)) dd-pi) (dd-%log number)))) ((complex) (complex-log number))))) (defun sqrt (number) "Return the square root of NUMBER." (number-dispatch ((number number)) (((foreach fixnum bignum ratio)) (if (minusp number) (complex-sqrt number) (coerce (%sqrt (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (minusp number) (complex-sqrt number) (coerce (%sqrt (coerce number 'double-float)) '(dispatch-type number)))) #+double-double ((double-double-float) (if (minusp number) (dd-complex-sqrt number) (multiple-value-bind (hi lo) (c::sqrt-dd (kernel:double-double-hi number) (kernel:double-double-lo number)) (kernel:%make-double-double-float hi lo)))) ((complex) (complex-sqrt number)))) ;;;; Trigonometic and Related Functions (defun abs (number) "Returns the absolute value of the number." (number-dispatch ((number number)) (((foreach single-float double-float fixnum rational #+double-double double-double-float)) (abs number)) ((complex) (let ((rx (realpart number)) (ix (imagpart number))) (etypecase rx (rational (sqrt (+ (* rx rx) (* ix ix)))) (single-float (coerce (%hypot (coerce rx 'double-float) (coerce ix 'double-float)) 'single-float)) (double-float (%hypot rx ix)) #+double-double (double-double-float (multiple-value-bind (abs^2 scale) (dd-cssqs number) (scale-float (sqrt abs^2) scale)))))))) (defun phase (number) "Returns the angle part of the polar representation of a complex number. For complex numbers, this is (atan (imagpart number) (realpart number)). For non-complex positive numbers, this is 0. For non-complex negative numbers this is PI." (etypecase number (rational (if (minusp number) (coerce pi 'single-float) 0.0f0)) (single-float (if (minusp (float-sign number)) (coerce pi 'single-float) 0.0f0)) (double-float (if (minusp (float-sign number)) (coerce pi 'double-float) 0.0d0)) #+double-double (double-double-float (if (minusp (float-sign number)) dd-pi 0w0)) (complex (atan (imagpart number) (realpart number))))) (defun sin (number) "Return the sine of NUMBER." (number-dispatch ((number number)) (handle-reals %sin number) ((complex) (let ((x (realpart number)) (y (imagpart number))) (complex (* (sin x) (cosh y)) (* (cos x) (sinh y))))))) (defun cos (number) "Return the cosine of NUMBER." (number-dispatch ((number number)) (handle-reals %cos number) ((complex) (let ((x (realpart number)) (y (imagpart number))) (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y)))))))) (defun tan (number) "Return the tangent of NUMBER." (number-dispatch ((number number)) (handle-reals %tan number) ((complex) (complex-tan number)))) (defun cis (theta) "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)." (if (complexp theta) (error (intl:gettext "Argument to CIS is complex: ~S") theta) (number-dispatch ((theta real)) ((rational) (let ((arg (coerce theta 'double-float))) (multiple-value-bind (s c) (%sincos arg) (complex (coerce c 'single-float) (coerce s 'single-float))))) (((foreach single-float double-float)) (multiple-value-bind (s c) (%sincos (coerce theta 'double-float)) (complex (coerce c '(dispatch-type theta)) (coerce s '(dispatch-type theta))))) #+double-double ((double-double-float) (multiple-value-bind (s c) (dd-%sincos theta) (complex c s)))))) (defun asin (number) "Return the arc sine of NUMBER." (number-dispatch ((number number)) ((rational) (if (or (> number 1) (< number -1)) (complex-asin number) (coerce (%asin (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (float-nan-p number) (and (<= number (coerce 1 '(dispatch-type number))) (>= number (coerce -1 '(dispatch-type number))))) (coerce (%asin (coerce number 'double-float)) '(dispatch-type number)) (complex-asin number))) #+double-double ((double-double-float) (if (or (float-nan-p number) (and (<= number 1w0) (>= number -1w0))) (dd-%asin number) (dd-complex-asin number))) ((complex) (complex-asin number)))) (defun acos (number) "Return the arc cosine of NUMBER." (number-dispatch ((number number)) ((rational) (if (or (> number 1) (< number -1)) (complex-acos number) (coerce (%acos (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (float-nan-p number) (and (<= number (coerce 1 '(dispatch-type number))) (>= number (coerce -1 '(dispatch-type number))))) (coerce (%acos (coerce number 'double-float)) '(dispatch-type number)) (complex-acos number))) #+double-double ((double-double-float) (if (or (float-nan-p number) (and (<= number 1w0) (>= number -1w0))) (dd-%acos number) (complex-acos number))) ((complex) (complex-acos number)))) (defun atan (y &optional (x nil xp)) "Return the arc tangent of Y if X is omitted or Y/X if X is supplied." (if xp (flet ((atan2 (y x) (declare (type double-float y x) (values double-float)) (if (zerop x) (if (zerop y) (if (plusp (float-sign x)) y (float-sign y pi)) (float-sign y (/ pi 2))) (%atan2 y x)))) ;; If X is given, both X and Y must be real numbers. (number-dispatch ((y real) (x real)) ((double-float (foreach double-float single-float fixnum bignum ratio)) (atan2 y (coerce x 'double-float))) (((foreach single-float fixnum bignum ratio) double-float) (atan2 (coerce y 'double-float) x)) (((foreach single-float fixnum bignum ratio) (foreach single-float fixnum bignum ratio)) (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float)) 'single-float)) #+double-double ((double-double-float (foreach double-double-float double-float single-float fixnum bignum ratio)) (dd-%atan2 y (coerce x 'double-double-float))) #+double-double (((foreach double-float single-float fixnum bignum ratio) double-double-float) (dd-%atan2 (coerce y 'double-double-float) x)))) (number-dispatch ((y number)) (handle-reals %atan y) ((complex) (complex-atan y))))) (defun sinh (number) "Return the hyperbolic sine of NUMBER." (number-dispatch ((number number)) (handle-reals %sinh number) ((complex) (let ((x (realpart number)) (y (imagpart number))) (complex (* (sinh x) (cos y)) (* (cosh x) (sin y))))))) (defun cosh (number) "Return the hyperbolic cosine of NUMBER." (number-dispatch ((number number)) (handle-reals %cosh number) ((complex) (let ((x (realpart number)) (y (imagpart number))) (complex (* (cosh x) (cos y)) (* (sinh x) (sin y))))))) (defun tanh (number) "Return the hyperbolic tangent of NUMBER." (number-dispatch ((number number)) (handle-reals %tanh number) ((complex) (complex-tanh number)))) (defun asinh (number) "Return the hyperbolic arc sine of NUMBER." (number-dispatch ((number number)) (handle-reals %asinh number) ((complex) (complex-asinh number)))) (defun acosh (number) "Return the hyperbolic arc cosine of NUMBER." (number-dispatch ((number number)) ((rational) ;; acosh is complex if number < 1 (if (< number 1) (complex-acosh number) (coerce (%acosh (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (< number (coerce 1 '(dispatch-type number))) (complex-acosh number) (coerce (%acosh (coerce number 'double-float)) '(dispatch-type number)))) #+double-double ((double-double-float) (if (< number 1w0) (complex-acosh number) (dd-%acosh number))) ((complex) (complex-acosh number)))) (defun atanh (number) "Return the hyperbolic arc tangent of NUMBER." (number-dispatch ((number number)) ((rational) ;; atanh is complex if |number| > 1 (if (or (> number 1) (< number -1)) (complex-atanh number) (coerce (%atanh (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (> number (coerce 1 '(dispatch-type number))) (< number (coerce -1 '(dispatch-type number)))) (complex-atanh number) (coerce (%atanh (coerce number 'double-float)) '(dispatch-type number)))) #+double-double ((double-double-float) (if (or (> number 1w0) (< number -1w0)) (complex-atanh number) (dd-%atanh (coerce number 'double-double-float)))) ((complex) (complex-atanh number)))) ;;; HP-UX does not supply a C version of log1p, so use the definition. ;;; We really need to fix this. The definition really loses big-time ;;; in roundoff as x gets small. #+hpux (declaim (inline %log1p)) #+hpux (defun %log1p (number) (declare (double-float number) (optimize (speed 3) (safety 0))) (the double-float (log (the (double-float 0d0) (+ number 1d0))))) ;;;; ;;;; This is a set of routines that implement many elementary ;;;; transcendental functions as specified by ANSI Common Lisp. The ;;;; implementation is based on Kahan's paper. ;;;; ;;;; I believe I have accurately implemented the routines and are ;;;; correct, but you may want to check for your self. ;;;; ;;;; These functions are written for CMU Lisp and take advantage of ;;;; some of the features available there. It may be possible, ;;;; however, to port this to other Lisps. ;;;; ;;;; Some functions are significantly more accurate than the original ;;;; definitions in CMU Lisp. In fact, some functions in CMU Lisp ;;;; give the wrong answer like (acos #c(-2.0 0.0)), where the true ;;;; answer is pi + i*log(2-sqrt(3)). ;;;; ;;;; All of the implemented functions will take any number for an ;;;; input, but the result will always be a either a complex ;;;; single-float or a complex double-float. ;;;; ;;;; General functions ;;;; complex-sqrt ;;;; complex-log ;;;; complex-atanh ;;;; complex-tanh ;;;; complex-acos ;;;; complex-acosh ;;;; complex-asin ;;;; complex-asinh ;;;; complex-atan ;;;; complex-tan ;;;; ;;;; Utility functions: ;;;; scalb logb ;;;; ;;;; Internal functions: ;;;; square coerce-to-complex-type cssqs complex-log-scaled ;;;; ;;;; ;;;; Please send any bug reports, comments, or improvements to Raymond ;;;; Toy at toy@rtp.ericsson.se. ;;;; ;;;; References ;;;; ;;;; Kahan, W. "Branch Cuts for Complex Elementary Functions, or Much ;;;; Ado About Nothing's Sign Bit" in Iserles and Powell (eds.) "The ;;;; State of the Art in Numerical Analysis", pp. 165-211, Clarendon ;;;; Press, 1987 ;;;; (declaim (inline square)) (defun square (x) (declare (float x)) (* x x)) ;; If you have these functions in libm, perhaps they should be used ;; instead of these Lisp versions. These versions are probably good ;; enough, especially since they are portable. (declaim (inline scalb)) (defun scalb (x n) "Compute 2^N * X without compute 2^N first (use properties of the underlying floating-point format" (declare (type float x) (type double-float-exponent n)) (scale-float x n)) (declaim (inline logb-finite)) (defun logb-finite (x) "Same as logb but X is not infinity and non-zero and not a NaN, so that we can always return an integer" (declare (type float x)) (multiple-value-bind (signif expon sign) (decode-float x) (declare (ignore signif sign)) ;; decode-float is almost right, except that the exponent ;; is off by one (1- expon))) (defun logb (x) "Compute an integer N such that 1 <= |2^(-N) * x| < 2. For the special cases, the following values are used: x logb NaN NaN +/- infinity +infinity 0 -infinity " (declare (type float x)) (cond ((float-nan-p x) x) ((float-infinity-p x) #.ext:double-float-positive-infinity) ((zerop x) ;; The answer is negative infinity, but we are supposed to ;; signal divide-by-zero, so do the actual division (/ -1 x) ) (t (logb-finite x)))) ;; This function is used to create a complex number of the appropriate ;; type. (declaim (inline coerce-to-complex-type)) (defun coerce-to-complex-type (x y z) "Create complex number with real part X and imaginary part Y such that it has the same type as Z. If Z has type (complex rational), the X and Y are coerced to single-float." (declare (double-float x y) (number z) (optimize (extensions:inhibit-warnings 3))) (if (typep (realpart z) 'double-float) (complex x y) ;; Convert anything that's not a double-float to a single-float. (complex (float x 1f0) (float y 1f0)))) (defun cssqs (z) ;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The ;; result is r + i*k, where k is an integer. ;; Save all FP flags (let ((x (float (realpart z) 1d0)) (y (float (imagpart z) 1d0))) ;; Would this be better handled using an exception handler to ;; catch the overflow or underflow signal? For now, we turn all ;; traps off and look at the accrued exceptions to see if any ;; signal would have been raised. (with-float-traps-masked (:underflow :overflow) (let ((rho (+ (square x) (square y)))) (declare (optimize (speed 3) (space 0))) (cond ((and (or (float-nan-p rho) (float-infinity-p rho)) (or (float-infinity-p (abs x)) (float-infinity-p (abs y)))) (values ext:double-float-positive-infinity 0)) ((let ((threshold #.(/ least-positive-double-float double-float-epsilon)) (traps (ldb vm::float-sticky-bits (vm:floating-point-modes)))) ;; Overflow raised or (underflow raised and rho < ;; lambda/eps) (or (not (zerop (logand vm:float-overflow-trap-bit traps))) (and (not (zerop (logand vm:float-underflow-trap-bit traps))) (< rho threshold)))) ;; If we're here, neither x nor y are infinity and at ;; least one is non-zero.. Thus logb returns a nice ;; integer. (let ((k (- (logb-finite (max (abs x) (abs y)))))) (values (+ (square (scalb x k)) (square (scalb y k))) (- k)))) (t (values rho 0))))))) (defun complex-sqrt (z) "Principle square root of Z Z may be any number, but the result is always a complex." (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-sqrt (dd-complex-sqrt z))) (multiple-value-bind (rho k) (cssqs z) (declare (type (or (member 0d0) (double-float 0d0)) rho) (type fixnum k)) (let ((x (float (realpart z) 1.0d0)) (y (float (imagpart z) 1.0d0)) (eta 0d0) (nu 0d0)) (declare (double-float x y eta nu)) (locally ;; space 0 to get maybe-inline functions inlined. (declare (optimize (speed 3) (space 0))) (if (not (locally (declare (optimize (inhibit-warnings 3))) (float-nan-p x))) (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) (cond ((oddp k) (setf k (ash k -1))) (t (setf k (1- (ash k -1))) (setf rho (+ rho rho)))) (setf rho (scalb (sqrt rho) k)) (setf eta rho) (setf nu y) (when (/= rho 0d0) (when (not (float-infinity-p (abs nu))) (setf nu (/ (/ nu rho) 2d0))) (when (< x 0d0) (setf eta (abs nu)) (setf nu (float-sign y rho)))) (coerce-to-complex-type eta nu z))))) (defun complex-log-scaled (z j) "Compute log(2^j*z). This is for use with J /= 0 only when |z| is huge." (declare (number z) (fixnum j)) ;; The constants t0, t1, t2 should be evaluated to machine ;; precision. In addition, Kahan says the accuracy of log1p ;; influences the choices of these constants but doesn't say how to ;; choose them. We'll just assume his choices matches our ;; implementation of log1p. (let ((t0 #.(/ 1 (sqrt 2.0d0))) (t1 1.2d0) (t2 3d0) (ln2 #.(log 2d0)) (x (float (realpart z) 1.0d0)) (y (float (imagpart z) 1.0d0))) (multiple-value-bind (rho k) (cssqs z) (declare (optimize (speed 3))) (let ((beta (max (abs x) (abs y))) (theta (min (abs x) (abs y)))) (coerce-to-complex-type (if (and (zerop k) (< t0 beta) (or (<= beta t1) (< rho t2))) (/ (%log1p (+ (* (- beta 1.0d0) (+ beta 1.0d0)) (* theta theta))) 2d0) (+ (/ (log rho) 2d0) (* (+ k j) ln2))) (atan y x) z))))) (defun complex-log (z) "Log of Z = log |Z| + i * arg Z Z may be any number, but the result is always a complex." (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-log (dd-complex-log-scaled z 0))) (complex-log-scaled z 0)) ;; Let us note the following "strange" behavior. atanh 1.0d0 is ;; +infinity, but the following code returns approx 176 + i*pi/4. The ;; reason for the imaginary part is caused by the fact that arg i*y is ;; never 0 since we have positive and negative zeroes. (defun complex-atanh (z) "Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-atanh (dd-complex-atanh z))) ;; When z is purely real and x > 1, we have ;; ;; atanh(z) = 1/2*(log(1+z) - log(1-z)) ;; = 1/2*(log(1+x) - (log(x-1)+i*pi)) ;; = 1/2*(log(1+x) - log(x-1) - i*pi) ;; = 1/2(log(1+x)-log(x-1)) - i*pi/2 ;; ;; Thus, the imaginary part is negative. Thus, for z > 1, atanh is ;; continuous with quadrant IV. To preserve the identity atanh(-z) ;; = -atanh(z), we must have atanh be continuous with Quadrant II ;; for z < -1. (The identity is obviously true from the ;; definition.) ;; ;; NOTE: this differs from what the CLHS says for the continuity. ;; Instead of the text in the CLHS, we choose to use the definition ;; to derive the correct values. (if (realp z) (complex-atanh (complex (float z) (- (* 0 (float z))))) (let* ( ;; Constants (theta (/ (sqrt most-positive-double-float) 4.0d0)) (rho (/ 4.0d0 (sqrt most-positive-double-float))) (half-pi (/ pi 2.0d0)) (rp (float (realpart z) 1.0d0)) (beta (float-sign rp 1.0d0)) (x (* beta rp)) (y (* beta (- (float (imagpart z) 1.0d0)))) (eta 0.0d0) (nu 0.0d0)) ;; Shouldn't need this declare. (declare (double-float x y)) (locally (declare (optimize (speed 3))) (cond ((or (> x theta) (> (abs y) theta)) ;; To avoid overflow... (setf nu (float-sign y half-pi)) ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), ;; which can cause overflow. Arrange this computation so ;; that it won't overflow. (setf eta (let* ((x-bigger (> x (abs y))) (r (if x-bigger (/ y x) (/ x y))) (d (+ 1.0d0 (* r r)))) (if x-bigger (/ (/ x) d) (/ (/ r y) d))))) ((= x 1.0d0) ;; Should this be changed so that if y is zero, eta is set ;; to +infinity instead of approx 176? In any case ;; tanh(176) is 1.0d0 within working precision. (let ((t1 (+ 4d0 (square y))) (t2 (+ (abs y) rho))) (setf eta (log (/ (sqrt (sqrt t1)) (sqrt t2)))) (setf nu (* 0.5d0 (float-sign y (+ half-pi (atan (* 0.5d0 t2)))))))) (t (let ((t1 (+ (abs y) rho))) ;; Normal case using log1p(x) = log(1 + x) (setf eta (* 0.25d0 (%log1p (/ (* 4.0d0 x) (+ (square (- 1.0d0 x)) (square t1)))))) (setf nu (* 0.5d0 (atan (* 2.0d0 y) (- (* (- 1.0d0 x) (+ 1.0d0 x)) (square t1)))))))) (coerce-to-complex-type (* beta eta) (- (* beta nu)) z))))) (defun complex-tanh (z) "Compute tanh z = sinh z / cosh z" (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-tanh (dd-complex-tanh z))) (let ((x (float (realpart z) 1.0d0)) (y (float (imagpart z) 1.0d0))) (locally ;; space 0 to get maybe-inline functions inlined (declare (optimize (speed 3) (space 0))) (cond ((> (abs x) #-(or linux hpux) #.(/ (%asinh most-positive-double-float) 4d0) ;; This is more accurate under linux. #+(or linux hpux) #.(/ (+ (%log 2.0d0) (%log most-positive-double-float)) 4d0)) (coerce-to-complex-type (float-sign x) (float-sign y) z)) (t (let* ((tv (%tan y)) (beta (+ 1.0d0 (* tv tv))) (s (sinh x)) (rho (sqrt (+ 1.0d0 (* s s))))) (if (float-infinity-p (abs tv)) (coerce-to-complex-type (/ rho s) (/ tv) z) (let ((den (+ 1.0d0 (* beta s s)))) (coerce-to-complex-type (/ (* beta rho s) den) (/ tv den) z))))))))) ;; Kahan says we should only compute the parts needed. Thus, the ;; realpart's below should only compute the real part, not the whole ;; complex expression. Doing this can be important because we may get ;; spurious signals that occur in the part that we are not using. ;; ;; However, we take a pragmatic approach and just use the whole ;; expression. ;; NOTE: The formula given by Kahan is somewhat ambiguous in whether ;; it's the conjugate of the square root or the square root of the ;; conjugate. This needs to be checked. ;; I checked. It doesn't matter because (conjugate (sqrt z)) is the ;; same as (sqrt (conjugate z)) for all z. This follows because ;; ;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z). ;; ;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z) ;; ;; and these two expressions are equal if and only if arg conj z = ;; -arg z, which is clearly true for all z. ;; NOTE: The rules of Common Lisp says that if you mix a real with a ;; complex, the real is converted to a complex before performing the ;; operation. However, Kahan says in this paper (pg 176): ;; ;; (iii) Careless handling can turn infinity or the sign of zero into ;; misinformation that subsequently disappears leaving behind ;; only a plausible but incorrect result. That is why compilers ;; must not transform z-1 into z-(1+i*0), as we have seen above, ;; nor -(-x-x^2) into (x+x^2), as we shall see below, lest a ;; subsequent logarithm or square root produce a non-zero ;; imaginary part whose sign is opposite to what was intended. ;; ;; The interesting examples are too long and complicated to reproduce ;; here. We refer the reader to his paper. ;; ;; The functions below are intended to handle the cases where a real ;; is mixed with a complex and we don't want CL complex contagion to ;; occur.. (declaim (inline 1+z 1-z z-1 z+1)) (defun 1+z (z) (complex (+ 1 (realpart z)) (imagpart z))) (defun 1-z (z) (complex (- 1 (realpart z)) (- (imagpart z)))) (defun z-1 (z) (complex (- (realpart z) 1) (imagpart z))) (defun z+1 (z) (complex (+ (realpart z) 1) (imagpart z))) (defun complex-acos (z) "Compute acos z = pi/2 - asin z Z may be any number, but the result is always a complex." (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-acos (dd-complex-acos z))) (if (and (realp z) (> z 1)) ;; acos is continuous in quadrant IV in this case. (complex-acos (complex z -0f0)) (let ((sqrt-1+z (complex-sqrt (1+z z))) (sqrt-1-z (complex-sqrt (1-z z)))) (with-float-traps-masked (:divide-by-zero) (complex (* 2 (atan (/ (realpart sqrt-1-z) (realpart sqrt-1+z)))) (asinh (imagpart (* (conjugate sqrt-1+z) sqrt-1-z)))))))) (defun complex-acosh (z) "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) Z may be any number, but the result is always a complex." (declare (number z)) (let ((sqrt-z-1 (complex-sqrt (z-1 z))) (sqrt-z+1 (complex-sqrt (z+1 z)))) (with-float-traps-masked (:divide-by-zero) (complex (asinh (realpart (* (conjugate sqrt-z-1) sqrt-z+1))) (* 2 (atan (/ (imagpart sqrt-z-1) (realpart sqrt-z+1)))))))) ;; What is the value of asin(2)? Here is a derivation. ;; ;; asin(2) = -i*log(i*2+sqrt(-3)) ;; = -i*log(2*i+sqrt(3)*i) ;; = -i*(log(2+sqrt(3)) + i*pi/2) ;; = pi/2 - i*log(2+sqrt(3)) ;; ;; Note that this differs from asin(2+0.0*i) because we support signed ;; zeroes. ;; ;; asin(2+0*i) = -i*log(i*(2+0*i) + sqrt(1-(4+0*i))) ;; = -i*log((2*i - 0) + sqrt(-3-0*i)) ;; = -i*log(-0 + 2*i - sqrt(3)*i) ;; = -i*log(-0 + i*(2-sqrt(3))) ;; = -i*(log(2-sqrt(3)) + i*pi/2) ;; = pi/2 - i*log(2-sqrt(3)) ;; = pi/2 + i*log(2+sqrt(3)) ;; ;; The last equation follows because (2-sqrt(3)) = 1/(2+sqrt(3)). ;; Hence asin(2) /= asin(2+0*i). ;; ;; Also ;; ;; asin(2-0*i) = -i*log(i*(2-0*i) + sqrt(1-(4-0*i))) ;; = -i*log((2*i + 0) + sqrt(-3+0*i)) ;; = -i*log(0 + 2*i + sqrt(3)*i) ;; = -i*log(0 + i*(2+sqrt(3))) ;; = -i*(log(2+sqrt(3)) + i*pi/2) ;; = pi/2 + i*log(2+sqrt(3)) ;; ;; Hence asin(2) = asin(2-0.0*i). ;; ;; Similar derivations will show that asin(-2) = asin(-2 + 0.0*i) and ;; asin(-2+0.0*i) is different from asin(-2-0.0*i) because of the ;; branch cut, of course. (defun complex-asin (z) "Compute asin z = -i*log(i*z + sqrt(1-z^2)) Z may be any number, but the result is always a complex." (declare (number z)) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-asin (dd-complex-asin z))) (if (and (realp z) (> z 1)) ;; asin is continuous in quadrant IV in this case. (complex-asin (complex z -0f0)) (let ((sqrt-1-z (complex-sqrt (1-z z))) (sqrt-1+z (complex-sqrt (1+z z)))) (with-float-traps-masked (:divide-by-zero) (complex (atan (/ (realpart z) (realpart (* sqrt-1-z sqrt-1+z)))) (asinh (imagpart (* (conjugate sqrt-1-z) sqrt-1+z)))))))) (defun complex-asinh (z) "Compute asinh z = log(z + sqrt(1 + z*z)) Z may be any number, but the result is always a complex." (declare (number z)) ;; asinh z = -i * asin (i*z) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-asinh (dd-complex-asinh z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-asin iz))) (complex (imagpart result) (- (realpart result))))) (defun complex-atan (z) "Compute atan z = (log(1+i*z) - log(1-i*z))/(2*i) Z may be any number, but the result is always a complex." (declare (number z)) ;; atan z = -i * atanh (i*z) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-atan (dd-complex-atan z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-atanh iz))) (complex (imagpart result) (- (realpart result))))) (defun complex-tan (z) "Compute tan z = -i * tanh(i * z) Z may be any number, but the result is always a complex." (declare (number z)) ;; tan z = -i * tanh(i*z) #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-tan (dd-complex-tan z))) (let* ((iz (complex (- (imagpart z)) (realpart z))) (result (complex-tanh iz))) (complex (imagpart result) (- (realpart result))))) cmucl-21a/src/code/kernel.lisp000066400000000000000000000135021260377556400164340ustar00rootroot00000000000000;;; -*- Log: code.log; Package: KERNEL -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/kernel.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; (in-package "KERNEL") (intl:textdomain "cmucl") (export '(allocate-vector make-array-header function-subtype)) (defun get-header-data (x) "Return the 24 bits of data in the header of object X, which must be an other-pointer object." (get-header-data x)) (defun set-header-data (x val) "Sets the 24 bits of data in the header of object X (which must be an other-pointer object) to VAL." (set-header-data x val)) (defun get-closure-length (x) "Returns the length of the closure X. This is one more than the number of variables closed over." (get-closure-length x)) (defun get-lowtag (x) "Returns the three-bit lowtag for the object X." (get-lowtag x)) (defun get-type (x) "Returns the 8-bit header type for the object X." (get-type x)) (defun vector-sap (x) "Return a System-Area-Pointer pointing to the data for the vector X, which must be simple." (declare (type (simple-unboxed-array (*)) x)) (vector-sap x)) (defun c::binding-stack-pointer-sap () "Return a System-Area-Pointer pointing to the end of the binding stack." (c::binding-stack-pointer-sap)) (defun c::dynamic-space-free-pointer () "Returns a System-Area-Pointer pointing to the next free work of the current dynamic space." (c::dynamic-space-free-pointer)) (defun c::control-stack-pointer-sap () "Return a System-Area-Pointer pointing to the end of the control stack." (c::control-stack-pointer-sap)) (defun function-subtype (function) "Return the header typecode for FUNCTION. Can be set with SETF." (function-subtype function)) (defun (setf function-subtype) (type function) (setf (function-subtype function) type)) (defun %function-arglist (func) "Extracts the arglist from the function header FUNC." (%function-arglist func)) (defun %function-name (func) "Extracts the name from the function header FUNC." (%function-name func)) (defun %function-type (func) "Extracts the type from the function header FUNC." (%function-type func)) (defun %closure-function (closure) "Extracts the function from CLOSURE." (%closure-function closure)) (defun c::vector-length (vector) "Return the length of VECTOR. There is no reason to use this, 'cause (length (the vector foo)) is the same." (c::vector-length vector)) (defun %sxhash-simple-string (string) "Return the SXHASH for the simple-string STRING." (%sxhash-simple-string string)) (defun %sxhash-simple-substring (string length) "Return the SXHASH for the first LENGTH characters of the simple-string STRING." (%sxhash-simple-substring string length)) (defun %closure-index-ref (closure index) "Extract the INDEXth slot from CLOSURE." (%closure-index-ref closure index)) (defun allocate-vector (type length words) "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and WORDS words long. Note: it is your responsibility to assure that the relation between LENGTH and WORDS is correct." (allocate-vector type length words)) (defun make-array-header (type rank) "Allocate an array header with type code TYPE and rank RANK." (make-array-header type rank)) (defun code-instructions (code-obj) "Return a SAP pointing to the instructions part of CODE-OBJ." (code-instructions code-obj)) (defun code-header-ref (code-obj index) "Extract the INDEXth element from the header of CODE-OBJ. Can be set with setf." (code-header-ref code-obj index)) (defun code-header-set (code-obj index new) (code-header-set code-obj index new)) (defsetf code-header-ref code-header-set) (defun %raw-bits (object offset) (declare (type index offset)) (kernel:%raw-bits object offset)) (defun %set-raw-bits (object offset value) (declare (type index offset) (type (unsigned-byte #.vm:word-bits) value)) (setf (kernel:%raw-bits object offset) value)) (defsetf %raw-bits %set-raw-bits) (defun make-single-float (x) (make-single-float x)) (defun make-double-float (hi lo) (make-double-float hi lo)) #+long-float (defun make-long-float (exp hi #+sparc mid lo) (make-long-float exp hi #+sparc mid lo)) #+double-double (defun %make-double-double-float (hi lo) (%make-double-double-float hi lo)) #+double-double (declaim (inline make-double-double-float)) #+double-double (defun make-double-double-float (hi lo) ;; Make sure the parts make sense for a double-double (declare (double-float hi lo) (inline float-infinity-p float-nan-p)) (if (or (float-infinity-p hi) (float-nan-p hi)) (%make-double-double-float hi lo) (multiple-value-bind (s e) (c::two-sum hi lo) (%make-double-double-float s e)))) #+double-double (defun double-double-hi (x) (double-double-hi x)) #+double-double (defun double-double-lo (x) (double-double-lo x)) (defun single-float-bits (x) (single-float-bits x)) (defun double-float-high-bits (x) (double-float-high-bits x)) (defun double-float-low-bits (x) (double-float-low-bits x)) #+long-float (defun long-float-exp-bits (x) (long-float-exp-bits x)) #+long-float (defun long-float-high-bits (x) (long-float-high-bits x)) #+(and long-float sparc) (defun long-float-mid-bits (x) (long-float-mid-bits x)) #+long-float (defun long-float-low-bits (x) (long-float-low-bits x)) #+(or sparc ppc (and x86 sse2)) (defun double-float-bits (x) (double-float-bits x)) #-(or sparc ppc (and x86 sse2)) (defun double-float-bits (x) (values (double-float-high-bits x) (double-float-low-bits x))) (defun %numerator (x) (declare (type ratio x)) (%numerator x)) (defun %denominator (x) (declare (type ratio x)) (%denominator x)) cmucl-21a/src/code/linux-os.lisp000066400000000000000000000042421260377556400167330ustar00rootroot00000000000000;;; -*- Package: SYSTEM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/linux-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMUCL under Linux. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. ;;; ;;; Derived from mach-os.lisp by Paul Werkowski (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl-linux-os") (export '(get-system-info get-page-size os-init)) (register-lisp-feature :linux) (register-lisp-feature :elf) (register-lisp-runtime-feature :executable) (setq *software-type* "Linux") ;;; Instead of reading /proc/version (which has some bugs with ;;; select() in Linux kernel 2.6.x) and instead of running uname -r, ;;; let's just get the info from uname(). (defun software-version () "Returns a string describing version of the supporting software." (multiple-value-bind (sysname nodename release version) (unix:unix-uname) (declare (ignore sysname nodename)) (concatenate 'string release " " version))) ;;; OS-Init initializes our operating-system interface. ;;; (defun os-init () nil) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (unless err? (error (intl:gettext "Unix system call getrusage failed: ~A.") (unix:get-unix-error-msg utime))) (values utime stime majflt))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (multiple-value-bind (val err) (unix:unix-getpagesize) (unless val (error (intl:gettext "Getpagesize failed: ~A") (unix:get-unix-error-msg err))) val)) cmucl-21a/src/code/lispinit.lisp000066400000000000000000000555011260377556400170140ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/lispinit.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Initialization stuff for CMU Common Lisp, plus some other random functions ;;; that we don't have any better place for. ;;; ;;; Written by Skef Wholey and Rob MacLachlan. ;;; (in-package :lisp) (intl:textdomain "cmucl") (export '(most-positive-fixnum most-negative-fixnum sleep ++ +++ ** *** // ///)) (defvar *features* '(:common-lisp :ansi-cl :ieee-floating-point :cmu) "Holds a list of symbols that describe features provided by the implementation.") (in-package :system) (export '(compiler-version scrub-control-stack *runtime-features*)) (defvar *runtime-features* nil "Features affecting the runtime") (in-package :extensions) (export '(quit *prompt*)) (in-package :lisp) #+stack-checking (sys:register-lisp-runtime-feature :stack-checking) ;; Currently, heap-overflow-check depends on gencgc. #+(and heap-overflow-check gencgc) (sys:register-lisp-runtime-feature :heap-overflow-check) #+double-double (sys:register-lisp-feature :double-double) #+alien-callback (sys:register-lisp-feature :alien-callback) ;;; Make the error system enable interrupts. (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum "The fixnum closest in value to positive infinity.") (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum "The fixnum closest in value to negative infinity.") ;;; Random information: (defvar *lisp-implementation-version* "4.0(?)") ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs... (declaim #-gengc (special *gc-inhibit* *already-maybe-gcing* *need-to-collect-garbage* *gc-verbose* *before-gc-hooks* *after-gc-hooks* #+x86 *pseudo-atomic-atomic* #+x86 *pseudo-atomic-interrupted* unix::*interrupts-enabled* unix::*interrupt-pending* *type-system-initialized* unix::*filename-encoding*) #+gengc (special *gc-verbose* *before-gc-hooks* *after-gc-hooks* *type-system-initialized* unix::*filename-encoding*)) ;;;; Random magic specials. ;;; These are filled in by Genesis. #-gengc (progn (defvar *current-catch-block*) (defvar *current-unwind-protect-block*) (defvar *free-interrupt-context-index*) ); #-gengc progn ;;;; Random stuff that needs to be in the cold load which would otherwise be ;;;; byte-compiled. ;;;; (defvar hi::*in-the-editor* nil) ;;;; Called by defmacro expanders... ;;; VERIFY-KEYWORDS -- internal ;;; ;;; Determine if key-list is a valid list of keyword/value pairs. Do not ;;; signal the error directly, 'cause we don't know how it should be signaled. ;;; (defun verify-keywords (key-list valid-keys allow-other-keys) (do ((already-processed nil) (unknown-keyword nil) (remaining key-list (cddr remaining))) ((null remaining) (if (and unknown-keyword (not allow-other-keys) (not (lookup-keyword :allow-other-keys key-list))) (values :unknown-keyword (list unknown-keyword valid-keys)) (values nil nil))) (cond ((not (and (consp remaining) (listp (cdr remaining)))) (return (values :dotted-list key-list))) ((null (cdr remaining)) (return (values :odd-length key-list))) #+nil ;; Not ANSI compliant to disallow duplicate keywords. ((member (car remaining) already-processed) (return (values :duplicate (car remaining)))) ((or (eq (car remaining) :allow-other-keys) (member (car remaining) valid-keys)) (push (car remaining) already-processed)) (t (setf unknown-keyword (car remaining)))))) (defun lookup-keyword (keyword key-list) (do ((remaining key-list (cddr remaining))) ((endp remaining)) (when (eq keyword (car remaining)) (return (cadr remaining))))) ;;; (defun keyword-supplied-p (keyword key-list) (do ((remaining key-list (cddr remaining))) ((endp remaining)) (when (eq keyword (car remaining)) (return t)))) (in-package "CONDITIONS") (defvar *break-on-signals* nil "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will enter the debugger prior to signalling that condition.") (defun signal (datum &rest arguments) "Invokes the signal facility on a condition formed from datum and arguments. If the condition is not handled, nil is returned. If (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before any signalling is done." (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal)) (*handler-clusters* *handler-clusters*)) (let ((obos *break-on-signals*) (*break-on-signals* nil)) (when (typep condition obos) (break (intl:gettext "~A~%Break entered because of *break-on-signals* (now NIL.)") condition))) (loop (unless *handler-clusters* (return)) (let ((cluster (pop *handler-clusters*))) (dolist (handler cluster) (when (typep condition (car handler)) (funcall (cdr handler) condition))))) nil)) ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single ;;; argument that's directly usable by all the other routines. ;;; (defun coerce-to-condition (datum arguments default-type function-name) (cond ((typep datum 'condition) (if arguments (cerror (intl:gettext "Ignore the additional arguments.") 'simple-type-error :datum arguments :expected-type 'null :format-control (intl:gettext "You may not supply additional arguments ~ when giving ~S to ~S.") :format-arguments (list datum function-name))) datum) ((symbolp datum) ;Roughly, (subtypep datum 'condition). (apply #'make-condition datum arguments)) ((or (stringp datum) (functionp datum)) (make-condition default-type :format-control datum :format-arguments arguments)) (t (error 'simple-type-error :datum datum :expected-type '(or symbol string) :format-control (intl:gettext "Bad argument to ~S: ~S") :format-arguments (list function-name datum))))) (defun error (datum &rest arguments) "Invokes the signal facility on a condition formed from datum and arguments. If the condition is not handled, the debugger is invoked." (kernel:infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)) (debug:*stack-top-hint* debug:*stack-top-hint*)) (unless (and (condition-function-name condition) debug:*stack-top-hint*) (multiple-value-bind (name frame) (kernel:find-caller-name) (unless (condition-function-name condition) (setf (condition-function-name condition) name)) (unless debug:*stack-top-hint* (setf debug:*stack-top-hint* frame)))) (let ((debug:*stack-top-hint* nil)) (signal condition)) (invoke-debugger condition)))) ;;; CERROR must take care to not use arguments when datum is already a ;;; condition object. ;;; (defun cerror (continue-string datum &rest arguments) (kernel:infinite-error-protect (with-simple-restart (continue "~A" (apply #'format nil continue-string arguments)) (let ((condition (if (typep datum 'condition) datum (coerce-to-condition datum arguments 'simple-error 'error))) (debug:*stack-top-hint* debug:*stack-top-hint*)) (unless (and (condition-function-name condition) debug:*stack-top-hint*) (multiple-value-bind (name frame) (kernel:find-caller-name) (unless (condition-function-name condition) (setf (condition-function-name condition) name)) (unless debug:*stack-top-hint* (setf debug:*stack-top-hint* frame)))) (with-condition-restarts condition (list (find-restart 'continue)) (let ((debug:*stack-top-hint* nil)) (signal condition)) (invoke-debugger condition))))) nil) (defun break (&optional (datum "Break") &rest arguments) "Prints a message and invokes the debugger without allowing any possibility of condition handling occurring." (kernel:infinite-error-protect (with-simple-restart (continue (intl:gettext "Return from BREAK.")) (let ((debug:*stack-top-hint* (or debug:*stack-top-hint* (nth-value 1 (kernel:find-caller-name))))) (invoke-debugger (coerce-to-condition datum arguments 'simple-condition 'break))))) nil) (defun warn (datum &rest arguments) "Warns about a situation by signalling a condition formed by datum and arguments. While the condition is being signaled, a muffle-warning restart exists that causes WARN to immediately return nil." (kernel:infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn))) (check-type condition warning (intl:gettext "a warning condition")) (restart-case (signal condition) (muffle-warning () :report (lambda (stream) (write-string (intl:gettext "Skip warning.") stream)) (return-from warn nil))) (format *error-output* (intl:gettext "~&~@~%") condition))) nil) ;;; Utility functions (defun simple-program-error (datum &rest arguments) "Invokes the signal facility on a condition formed from datum and arguments. If the condition is not handled, the debugger is invoked. This function is just like error, except that the condition type defaults to the type simple-program-error, instead of program-error." (kernel:infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-program-error 'simple-program-error)) (debug:*stack-top-hint* debug:*stack-top-hint*)) (unless (and (condition-function-name condition) debug:*stack-top-hint*) (multiple-value-bind (name frame) (kernel:find-caller-name) (unless (condition-function-name condition) (setf (condition-function-name condition) name)) (unless debug:*stack-top-hint* (setf debug:*stack-top-hint* frame)))) (let ((debug:*stack-top-hint* nil)) (signal condition)) (invoke-debugger condition)))) (in-package "LISP") ;;; %Initial-Function is called when a cold system starts up. First we zoom ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen ;;; at "load time." Then we initialize the various subsystems and call the ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until ;;; someone (most likely the Quit function) throws to the tag ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms ;;; in Unwind-Protects will get executed. (declaim (special *lisp-initialization-functions* *load-time-values*)) (eval-when (compile) (defmacro print-and-call (name) `(progn (%primitive print ,(symbol-name name)) (,name)))) #+nil (defun hexstr(thing) (let ((addr (kernel:get-lisp-obj-address thing)) (str (make-string 10))) (setf (char str 0) #\0 (char str 1) #\x) (dotimes (i 8) (let* ((nib (ldb (byte 4 0) addr)) (chr (char "0123456789abcdef" nib))) (declare (type (unsigned-byte 4) nib) (base-char chr)) (setf (char str (- 9 i)) chr addr (ash addr -4)))) str)) (defun %initial-function () "Gives the world a shove and hopes it spins." (%primitive print "In initial-function, and running.") #-gengc (setf *already-maybe-gcing* t) #-gengc (setf *gc-inhibit* t) #-gengc (setf *need-to-collect-garbage* nil) (setf *gc-verbose* #-gengc t #+gengc nil) (setf *before-gc-hooks* nil) (setf *after-gc-hooks* nil) #-gengc (setf unix::*interrupts-enabled* t) #-gengc (setf unix::*interrupt-pending* nil) (setf *type-system-initialized* nil) (setf *break-on-signals* nil) (setf unix::*filename-encoding* nil) #+gengc (setf conditions::*handler-clusters* nil) (setq intl::*default-domain* "cmucl") (setq intl::*locale* "C") ;; Many top-level forms call INFO, (SETF INFO). (print-and-call c::globaldb-init) ;; Set up the fdefn database. (print-and-call fdefn-init) ;; Some of the random top-level forms call Make-Array, which calls Subtypep (print-and-call typedef-init) (print-and-call class-init) (print-and-call type-init) (let ((funs (nreverse *lisp-initialization-functions*))) (%primitive print "Calling top-level forms.") #+nil (%primitive print (length funs)) (dolist (fun funs) #+nil (%primitive print fun) (typecase fun (function (funcall fun)) (cons (case (car fun) (:load-time-value (setf (svref *load-time-values* (third fun)) (funcall (second fun)))) (:load-time-value-fixup #-gengc (setf (#+amd64 sap-ref-64 #-amd64 sap-ref-32 (second fun) 0) (get-lisp-obj-address (svref *load-time-values* (third fun)))) #+gengc (do-load-time-value-fixup (second fun) (third fun) (fourth fun))) #+(and (or x86 amd64) gencgc) (:load-time-code-fixup (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun) (fifth fun))) (t (%primitive print "Bogus fixup in *lisp-initialization-functions*") (%halt)))) (t (%primitive print "Bogus function in *lisp-initialization-functions*") (%halt))))) (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed. (makunbound '*load-time-values*) ;; Only do this after top level forms have run, 'cause thats where ;; deftypes are. (setf *type-system-initialized* t) (print-and-call os-init) (print-and-call filesys-init) (print-and-call reader-init) ;; Note: sharpm and backq not yet loaded, so this is not the final RT. (setf *readtable* (copy-readtable std-lisp-readtable)) (print-and-call stream-init) (print-and-call loader-init) (print-and-call package-init) (print-and-call kernel::signal-init) (setf (alien:extern-alien "internal_errors_enabled" boolean) t) (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)) ;; This is necessary because some of the initial top level forms might ;; have changed the compilation policy in strange ways. (print-and-call c::proclaim-init) (print-and-call kernel::class-finalize) (setq intl::*default-domain* nil) (%primitive print "Done initializing.") #-gengc (setf *already-maybe-gcing* nil) #+gengc (setf *gc-verbose* t) (terpri) (princ "CMU Common Lisp kernel core image ") (princ (lisp-implementation-version)) (princ ".") (terpri) (princ "[You are in the LISP package.]") (terpri) (let ((wot (catch '%end-of-the-world (loop (%top-level) (write-line "You're certainly a clever child."))))) (unix:unix-exit wot))) #+gengc (defun do-load-time-value-fixup (object offset index) (declare (type index offset)) (macrolet ((lose (msg) `(progn (%primitive print ,msg) (%halt)))) (let ((value (svref *load-time-values* index))) (typecase object (list (case offset (0 (setf (car object) value)) (1 (setf (cdr object) value)) (t (lose "Bogus offset in cons cell.")))) (instance (setf (%instance-ref object (- offset vm:instance-slots-offset)) value)) (code-component (setf (code-header-ref object offset) value)) (simple-vector (setf (svref object (- offset vm:vector-data-offset)) value)) (t (lose "Unknown kind of object for load-time-value fixup.")))))) ;;;; Initialization functions: ;;; Print seems to not like x86 NPX denormal floats like ;;; least-negative-single-float, so the :underflow exceptions ;;; is disabled by default. Joe User can explicitly enable them ;;; if desired. (defun reinit () (without-interrupts (without-gcing (os-init) (stream-reinit) (kernel::signal-init) (gc-init) (setf (alien:extern-alien "internal_errors_enabled" boolean) t) (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)) ;; Clear pseudo atomic in case this core wasn't compiled with support. #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0)))) ;;;; Miscellaneous external functions: (defvar *cleanup-functions* nil "Functions to be invoked during cleanup at Lisp exit.") ;;; Quit gets us out, one way or another. (defun quit (&optional recklessly-p) "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is non-Nil." (if recklessly-p (unix:unix-exit 0) (progn (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*) (throw '%end-of-the-world 0)))) #-mp ; Multi-processing version defined in multi-proc.lisp. (defun sleep (n) _N"This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number." (when (or (not (realp n)) (minusp n)) (error 'simple-type-error :format-control "Invalid argument to SLEEP: ~S.~%~ Must be a non-negative, non-complex number." :format-arguments (list n) :datum n :expected-type '(real 0))) (multiple-value-bind (sec usec) (if (integerp n) (values n 0) (multiple-value-bind (sec frac) (truncate n) (values sec (truncate frac 1e-6)))) (unix:unix-select 0 0 0 0 sec usec)) nil) ;;;; SCRUB-CONTROL-STACK #+stack-checking (alien:def-alien-routine "os_guard_control_stack" c-call:void (zone c-call:int) (guardp c-call:int)) (defconstant bytes-per-scrub-unit 2048) ;;; Scrub-control-stack. ;;; #-(or x86 amd64) (defun %scrub-control-stack () _N"Zero the unused portion of the control stack so that old objects are not kept alive because of uninitialized stack variables." (declare (optimize (speed 3) (safety 0)) (values (unsigned-byte 20))) (labels ((scrub (ptr offset count) (declare (type system-area-pointer ptr) (type (unsigned-byte 16) offset) (type (unsigned-byte 20) count) (values (unsigned-byte 20))) (cond ((= offset bytes-per-scrub-unit) (look (sap+ ptr bytes-per-scrub-unit) 0 count)) (t (setf (sap-ref-32 ptr offset) 0) (scrub ptr (+ offset vm:word-bytes) count)))) (look (ptr offset count) (declare (type system-area-pointer ptr) (type (unsigned-byte 16) offset) (type (unsigned-byte 20) count) (values (unsigned-byte 20))) (cond ((= offset bytes-per-scrub-unit) count) ((zerop (sap-ref-32 ptr offset)) (look ptr (+ offset vm:word-bytes) count)) (t (scrub ptr offset (+ count vm:word-bytes)))))) (let* ((csp (sap-int (c::control-stack-pointer-sap))) (initial-offset (logand csp (1- bytes-per-scrub-unit)))) (declare (type (unsigned-byte 32) csp)) (scrub (int-sap (- csp initial-offset)) (* (floor initial-offset vm:word-bytes) vm:word-bytes) 0)))) ;;; Scrub-control-stack. ;;; ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on ;;; demand stacks the stack must be decreased as it is scrubbed. ;;; (defun scrub-control-stack () "Zero the unused portion of the control stack so that old objects are not kept alive because of uninitialized stack variables." ;; ;; The guard zone of the control stack is used by Lisp sometimes, ;; so I think it should be zero'd out, too. #+stack-checking (os-guard-control-stack 0 0) (%scrub-control-stack) #+stack-checking (os-guard-control-stack 0 1)) #+(or x86 amd64) (defun %scrub-control-stack () (%scrub-control-stack)) ;;;; TOP-LEVEL loop. (defvar / nil "Holds a list of all the values returned by the most recent top-level EVAL.") (defvar // nil "Gets the previous value of / when a new value is computed.") (defvar /// nil "Gets the previous value of // when a new value is computed.") (defvar * nil "Holds the value of the most recent top-level EVAL.") (defvar ** nil "Gets the previous value of * when a new value is computed.") (defvar *** nil "Gets the previous value of ** when a new value is computed.") (defvar + nil "Holds the value of the most recent top-level READ.") (defvar ++ nil "Gets the previous value of + when a new value is read.") (defvar +++ nil "Gets the previous value of ++ when a new value is read.") (defvar - nil "Holds the form curently being evaluated.") (defvar *prompt* "* " "The top-level prompt string. This also may be a function of no arguments that returns a simple-string.") (defvar *in-top-level-catcher* nil "True if we are within the Top-Level-Catcher. This is used by interrupt handlers to see whether it is o.k. to throw.") (defun interactive-eval (form) "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++, +, ///, //, /, and -." (when (and (fboundp 'commandp) (funcall 'commandp form)) (return-from interactive-eval (funcall 'invoke-command-interactive form))) (setf - form) (let ((results (multiple-value-list (eval form)))) (finish-standard-output-streams) (setf /// // // / / results *** ** ** * * (car results))) (setf +++ ++ ++ + + -) (unless (boundp '*) ;; The bogon returned an unbound marker. (setf * nil) (cerror (intl:gettext "Go on with * set to NIL.") (intl:gettext "EVAL returned an unbound marker."))) (values-list /)) (defconstant eofs-before-quit 10) (defparameter *reserved-heap-pages* 256 "How many pages to reserve from the total heap space so we can handle heap overflow.") #+heap-overflow-check (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long) (defun %top-level () "Top-level READ-EVAL-PRINT loop. Do not call this." (let ((* nil) (** nil) (*** nil) (- nil) (+ nil) (++ nil) (+++ nil) (/// nil) (// nil) (/ nil) (magic-eof-cookie (cons :eof nil)) (number-of-eofs 0)) (loop (with-simple-restart (abort (intl:gettext "Return to Top-Level.")) (catch 'top-level-catcher (unix:unix-sigsetmask 0) (let ((*in-top-level-catcher* t)) (loop (scrub-control-stack) (fresh-line) ;; Reset reserved pages in the heap #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*) (princ (if (functionp *prompt*) (funcall *prompt*) *prompt*)) (force-output) (let ((form (read *standard-input* nil magic-eof-cookie))) (cond ((not (eq form magic-eof-cookie)) (let ((results (multiple-value-list (interactive-eval form)))) (dolist (result results) (fresh-line) (prin1 result))) (setf number-of-eofs 0)) ((eql (incf number-of-eofs) 1) (if *batch-mode* (quit) (let ((stream (make-synonym-stream '*terminal-io*))) (setf *standard-input* stream) (setf *standard-output* stream) (format t (intl:gettext "~&Received EOF on *standard-input*, ~ switching to *terminal-io*.~%"))))) ((> number-of-eofs eofs-before-quit) (format t (intl:gettext "~&Received more than ~D EOFs; Aborting.~%") eofs-before-quit) (quit)) (t (format t (intl:gettext "~&Received EOF.~%")))))))))))) ;;; %Halt -- Interface ;;; ;;; A convenient way to get into the assembly level debugger. ;;; (defun %halt () (%primitive halt)) cmucl-21a/src/code/list.lisp000066400000000000000000001135261260377556400161360ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/list.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions to implement lists for Spice Lisp. ;;; Written by Joe Ginder and Carl Ebeling. ;;; Rewritten and currently maintained by Skef Wholey. ;;; ;;; Nsublis, things at the beginning broken. ;;; ;;; The list functions are part of the standard Spice Lisp environment. ;;; ;;; ********************************************************************** ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons tree-equal endp list-length nth first second third fourth fifth sixth seventh eighth ninth tenth rest nthcdr last list list* make-list append copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis member member-if member-if-not tailp adjoin union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not complement constantly)) (declaim (maybe-inline tree-equal list-length nth %setnth nthcdr last make-list append copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff member member-if member-if-not tailp adjoin union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) (in-package "EXTENSIONS") (export '(assq memq delq)) (declaim (maybe-inline delq)) (in-package "LISP") ;;; These functions perform basic list operations: (defun car (list) "Returns the 1st object in a list." (car list)) (defun cdr (list) "Returns all but the first object." (cdr list)) (defun cadr (list) "Returns the 2nd object in a list." (cadr list)) (defun cdar (list) "Returns the cdr of the 1st sublist." (cdar list)) (defun caar (list) "Returns the car of the 1st sublist." (caar list)) (defun cddr (list) "Returns all but the 1st two objects of a list." (cddr list)) (defun caddr (list) "Returns the 1st object in the cddr of a list." (caddr list)) (defun caadr (list) "Returns the 1st object in the cadr of a list." (caadr list)) (defun caaar (list) "Returns the 1st object in the caar of a list." (caaar list)) (defun cdaar (list) "Returns the cdr of the caar of a list." (cdaar list)) (defun cddar (list) "Returns the cdr of the cdar of a list." (cddar list)) (defun cdddr (list) "Returns the cdr of the cddr of a list." (cdddr list)) (defun cadar (list) "Returns the car of the cdar of a list." (cadar list)) (defun cdadr (list) "Returns the cdr of the cadr of a list." (cdadr list)) (defun caaaar (list) "Returns the car of the caaar of a list." (caaaar list)) (defun caaadr (list) "Returns the car of the caadr of a list." (caaadr list)) (defun caaddr (list) "Returns the car of the caddr of a list." (caaddr list)) (defun cadddr (list) "Returns the car of the cdddr of a list." (cadddr list)) (defun cddddr (list) "Returns the cdr of the cdddr of a list." (cddddr list)) (defun cdaaar (list) "Returns the cdr of the caaar of a list." (cdaaar list)) (defun cddaar (list) "Returns the cdr of the cdaar of a list." (cddaar list)) (defun cdddar (list) "Returns the cdr of the cddar of a list." (cdddar list)) (defun caadar (list) "Returns the car of the cadar of a list." (caadar list)) (defun cadaar (list) "Returns the car of the cdaar of a list." (cadaar list)) (defun cadadr (list) "Returns the car of the cdadr of a list." (cadadr list)) (defun caddar (list) "Returns the car of the cddar of a list." (caddar list)) (defun cdaadr (list) "Returns the cdr of the caadr of a list." (cdaadr list)) (defun cdadar (list) "Returns the cdr of the cadar of a list." (cdadar list)) (defun cdaddr (list) "Returns the cdr of the caddr of a list." (cdaddr list)) (defun cddadr (list) "Returns the cdr of the cdadr of a list." (cddadr list)) (defun cons (se1 se2) "Returns a list with se1 as the car and se2 as the cdr." (cons se1 se2)) (declaim (maybe-inline tree-equal-test tree-equal-test-not)) (defun tree-equal-test-not (x y test-not) (cond ((consp x) (and (consp y) (tree-equal-test-not (car x) (car y) test-not) (tree-equal-test-not (cdr x) (cdr y) test-not))) ((consp y) nil) ((not (funcall test-not x y)) t) (t ()))) (defun tree-equal-test (x y test) (cond ((consp x) (and (consp y) (tree-equal-test (car x) (car y) test) (tree-equal-test (cdr x) (cdr y) test))) ((consp y) nil) ((funcall test x y) t) (t ()))) (defun tree-equal (x y &key (test #'eql) test-not) "Returns T if X and Y are isomorphic trees with identical leaves." (if test-not (tree-equal-test-not x y test-not) (tree-equal-test x y test))) (defun endp (object) "The recommended way to test for the end of a list. True if Object is nil, false if Object is a cons, and an error for any other types of arguments." (endp object)) (defun list-length (list) "Returns the length of the given List, or Nil if the List is circular." (do ((n 0 (+ n 2)) (y list (cddr y)) (z list (cdr z))) (()) (declare (fixnum n) (list y z)) (when (endp y) (return n)) (when (endp (cdr y)) (return (+ n 1))) (when (and (eq y z) (> n 0)) (return nil)))) (defun nth (n list) "Returns the nth object in a list where the car is the zero-th element." (car (nthcdr n list))) (defun first (list) "Returns the 1st object in a list or NIL if the list is empty." (car list)) (defun second (list) "Returns the 2nd object in a list or NIL if there is no 2nd object." (cadr list)) (defun third (list) "Returns the 3rd object in a list or NIL if there is no 3rd object." (caddr list)) (defun fourth (list) "Returns the 4th object in a list or NIL if there is no 4th object." (cadddr list)) (defun fifth (list) "Returns the 5th object in a list or NIL if there is no 5th object." (car (cddddr list))) (defun sixth (list) "Returns the 6th object in a list or NIL if there is no 6th object." (cadr (cddddr list))) (defun seventh (list) "Returns the 7th object in a list or NIL if there is no 7th object." (caddr (cddddr list))) (defun eighth (list) "Returns the 8th object in a list or NIL if there is no 8th object." (cadddr (cddddr list))) (defun ninth (list) "Returns the 9th object in a list or NIL if there is no 9th object." (car (cddddr (cddddr list)))) (defun tenth (list) "Returns the 10th object in a list or NIL if there is no 10th object." (cadr (cddddr (cddddr list)))) (defun rest (list) "Means the same as the cdr of a list." (cdr list)) (defun nthcdr (n list) "Performs the cdr function n times on a list." (flet ((fast-nthcdr (n list) (declare (type index n)) (do ((i n (1- i)) (result list (cdr result))) ((not (plusp i)) result) (declare (type index i))))) (typecase n (index (fast-nthcdr n list)) (t (do ((i 0 (1+ i)) (r-i list (cdr r-i)) (r-2i list (cddr r-2i))) ((and (eq r-i r-2i) (not (zerop i))) (fast-nthcdr (mod n i) r-i)) (declare (type index i))))))) (defun last (list &optional (n 1)) "Returns the last N conses (not the last element!) of a list." (declare (type unsigned-byte n)) (if (typep n 'index) (do ((checked-list list (cdr checked-list)) (returned-list list) (index 0 (1+ index))) ((atom checked-list) returned-list) (declare (type index index)) (if (>= index n) (pop returned-list))) list)) (defun list (&rest args) "Returns constructs and returns a list of its arguments." args) ;;; List* is done the same as list, except that the last cons is made a ;;; dotted pair (defun list* (arg &rest others) "Returns a list of the arguments with last cons a dotted pair" (cond ((atom others) arg) ((atom (cdr others)) (cons arg (car others))) (t (do ((x others (cdr x))) ((null (cddr x)) (rplacd x (cadr x)))) (cons arg others)))) (defun make-list (size &key initial-element) "Constructs a list with size elements each set to value" (declare (type index size)) (do ((count size (1- count)) (result '() (cons initial-element result))) ((zerop count) result) (declare (type index count)))) ;; Test if LIST is a proper list. If so, the length of the list is ;; returned. (defun proper-list-p (list) ;; Basically the same as LIST-LENGTH, but with a few extra checks. (do ((n 0 (+ n 2)) (y list (cddr y)) (z list (cdr z))) (nil) (declare (fixnum n) (list y z)) (unless (listp y) (return nil)) (when (endp y) (return n)) (unless (listp (cdr y)) (return nil)) (when (endp (cdr y)) (return (+ n 1))) (when (and (eq y z) (> n 0)) (return nil)))) ;; Signal a simple-type-error that LIST is not a proper list. (defun not-proper-list-error (list) (error 'simple-type-error :datum list :expected-type '(satisfies proper-list-p) :format-control (intl:gettext "~S is not a proper list") :format-arguments (list list))) ;;; The outer loop finds the first non-null list and the result is started. ;;; The remaining lists in the arguments are tacked to the end of the result ;;; using splice which cdr's down the end of the new list (defun append (&rest args) "Typically, returns a new list that is the concatenation of Args. Each Arg in Args must be a proper list except the last one, which may be any object. The function is not destructive: for all but the last Arg, its list structure is copied. The last argument is not copied; it becomes the cdr of the final dotted pair of the concatenation of the preceding lists, or is returned directly if there are no preceding non-empty lists. In the latter case, if the last Arg is not a list, the returned value is not a list either." (do ((top args (cdr top))) ;;Cdr to first non-null list. ((atom top) '()) (cond ((null (car top))) ; Nil -> Keep looping ((not (consp (car top))) ; Non cons (if (cdr top) (error (intl:gettext "~S is not a list.") (car top)) (return (car top)))) (t ; Start appending (return (if (atom (cdr top)) (car top) ;;Special case. (let* ((result (cons (caar top) '())) (splice result)) (do ((x (cdar top) (cdr x))) ;;Copy first list ((atom x) (unless (null x) (not-proper-list-error (car top)))) (setq splice (cdr (rplacd splice (cons (car x) ()) ))) ) (do ((y (cdr top) (cdr y))) ;; Copy rest of args. ((atom (cdr y)) (setq splice (rplacd splice (car y))) result) (if (listp (car y)) (do ((x (car y) (cdr x))) ;;Inner copy loop. ((atom x) (unless (null x) (not-proper-list-error (car y)))) (setq splice (cdr (rplacd splice (cons (car x) ()))))) (error (intl:gettext "~S is not a list.") (car y))))))))))) ;;; List Copying Functions ;;; The list is copied correctly even if the list is not terminated by () ;;; The new list is built by cdr'ing splice which is always at the tail ;;; of the new list (defun copy-list (list) "Returns a new list EQUAL but not EQ to list" (if (atom list) list (let ((result (list (car list)))) (do ((x (cdr list) (cdr x)) (splice result (cdr (rplacd splice (cons (car x) '() ))) )) ((atom x) (unless (null x) (rplacd splice x)))) result))) (defun copy-alist (alist) "Returns a new association list equal to alist, constructed in space" (if (atom alist) alist (let ((result (cons (if (atom (car alist)) (car alist) (cons (caar alist) (cdar alist)) ) nil))) (do ((x (cdr alist) (cdr x)) (splice result (cdr (rplacd splice (cons (if (atom (car x)) (car x) (cons (caar x) (cdar x))) nil))))) ((atom x) (unless (null x) (not-proper-list-error alist)))) result))) (defun copy-tree (object) "Copy-Tree recursively copys trees of conses." (if (consp object) (cons (copy-tree (car object)) (copy-tree (cdr object))) object)) ;;; More Commonly-used List Functions (defun revappend (x y) "Returns (append (reverse x) y)" (do ((top x (cdr top)) (result y (cons (car top) result))) ((endp top) result))) ;;; NCONC finds the first non-null list, so it can make splice point to a cons. ;;; After finding the first cons element, it holds it in a result variable ;;; while running down successive elements tacking them together. While ;;; tacking lists together, if we encounter a null list, we set the previous ;;; list's last cdr to nil just in case it wasn't already nil, and it could ;;; have been dotted while the null list was the last argument to NCONC. The ;;; manipulation of splice (that is starting it out on a first cons, setting ;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x), ;;; and it avoids running down the last argument to NCONC which allows the last ;;; argument to be circular. ;;; (defun nconc (&rest lists) "Concatenates the lists given as arguments (by changing them)" (do ((top lists (cdr top))) ((null top) nil) (let ((top-of-top (car top))) (typecase top-of-top (cons (let* ((result top-of-top) (splice result)) (do ((elements (cdr top) (cdr elements))) ((endp elements)) (let ((ele (car elements))) (typecase ele (cons (rplacd (last splice) ele) (setf splice ele)) (null (rplacd (last splice) nil)) (atom (if (cdr elements) (error (intl:gettext "Argument is not a list -- ~S.") ele) (rplacd (last splice) ele))) (t (error (intl:gettext "Argument is not a list -- ~S.") ele))))) (return result))) (null) (atom (if (cdr top) (error (intl:gettext "Argument is not a list -- ~S.") top-of-top) (return top-of-top))) (t (error (intl:gettext "Argument is not a list -- ~S.") top-of-top)))))) (defun nreconc (x y) "Returns (nconc (nreverse x) y)" (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) (2nd x 1st) ;2nd follows first down the list. (3rd y 2nd)) ;3rd follows 2nd down the list. ((atom 2nd) (if 2nd ;; KLUDGE. The datum here is wrong. We really want X, but ;; we've already trashed it by the time we get here. So ;; use 2nd. (We could check X before doing anything, but ;; that makes this more expensive, so we don't.) (error 'simple-type-error :datum 2nd :expected-type 'list :format-control (intl:gettext "First argument is not a proper list.") :format-arguments nil) 3rd)) (rplacd 2nd 3rd))) (defun butlast (list &optional (n 1)) "Returns a new list the same as List without the last N conses. List must not be circular." (declare (list list) (type unsigned-byte n)) (when (and list (typep n 'index)) (let ((length (do ((list list (cdr list)) (i 0 (1+ i))) ((atom list) (1- i))))) (declare (type index length)) (unless (< length n) (do* ((top (cdr list) (cdr top)) (result (list (car list))) (splice result) (count length (1- count))) ((= count n) result) (declare (type index count)) (setq splice (cdr (rplacd splice (list (car top)))))))))) (defun nbutlast (list &optional (n 1)) "Modifies List to remove the last N conses. List must not be circular." (declare (list list) (type unsigned-byte n)) (when (and list (typep n 'index)) (let ((length (do ((list list (cdr list)) (i 0 (1+ i))) ((atom list) (1- i))))) (declare (type index length)) (unless (< length n) (do ((1st (cdr list) (cdr 1st)) (2nd list 1st) (count length (1- count))) ((= count n) (rplacd 2nd ()) list) (declare (type index count))))))) (defun ldiff (list object) "Returns a new list, whose elements are those of List that appear before Object. If Object is not a tail of List, a copy of List is returned. List must be a proper list or a dotted list." (do* ((list list (cdr list)) (result (list ())) (splice result)) ((atom list) (if (eql list object) (cdr result) (progn (rplacd splice list) (cdr result)))) (if (eql list object) (return (cdr result)) (setq splice (cdr (rplacd splice (list (car list)))))))) ;;; Functions to alter list structure (defun rplaca (x y) "Changes the car of x to y and returns the new x." (rplaca x y)) (defun rplacd (x y) "Changes the cdr of x to y and returns the new x." (rplacd x y)) ;;; The following are for use by SETF. (defun %rplaca (x val) (rplaca x val) val) (defun %rplacd (x val) (rplacd x val) val) (defun %setnth (n list newval) (declare (type index n)) "Sets the Nth element of List (zero based) to Newval." (do ((count n (1- count)) (list list (cdr list))) ((endp list) (error (intl:gettext "~S is too large an index for SETF of NTH.") n)) (declare (fixnum count)) (when (<= count 0) (rplaca list newval) (return newval)))) ;;;; :key arg optimization to save funcall of IDENTITY. ;;; APPLY-KEY saves us a function call sometimes. ;;; This is not in and (eval-when (compile eval) ... ;;; because this is used in seq.lisp and sort.lisp. ;;; (defmacro apply-key (key element) `(if ,key (funcall ,key ,element) ,element)) (defun identity (thing) "Returns what was passed to it." thing) (defun complement (function) "Builds a new function that returns T whenever FUNCTION returns NIL and NIL whenever FUNCTION returns T." #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) &rest more-args) (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) (arg2-p (funcall function arg0 arg1 arg2)) (arg1-p (funcall function arg0 arg1)) (arg0-p (funcall function arg0)) (t (funcall function)))))) (defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p) &rest more-values) "Builds a function that always returns VALUE, and posisbly MORE-VALUES." (cond (more-values (let ((list (list* value val1 val2 more-values))) #'(lambda () (declare (ext:optimize-interface (speed 3) (safety 0))) (values-list list)))) (val2-p #'(lambda () (declare (ext:optimize-interface (speed 3) (safety 0))) (values value val1 val2))) (val1-p #'(lambda () (declare (ext:optimize-interface (speed 3) (safety 0))) (values value val1))) (t #'(lambda () (declare (ext:optimize-interface (speed 3) (safety 0))) value)))) ;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)). ;;; Use these with the following keyword args: ;;; (defmacro with-set-keys (funcall) `(cond ((and testp notp) (error "Test and test-not both supplied.")) (notp ,(append funcall '(:key key :test-not test-not))) (t ,(append funcall '(:key key :test test))))) (defmacro satisfies-the-test (item elt) (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key ,elt))) (cond (testp (funcall test ,item ,key-tmp)) (notp (not (funcall test-not ,item ,key-tmp))) (t (funcall test ,item ,key-tmp)))))) ;;; Substitution of expressions (defun subst (new old tree &key key (test #'eql testp) (test-not nil notp)) "Substitutes new for subtrees matching old." (labels ((s (subtree) (cond ((satisfies-the-test old subtree) new) ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr))))))) (s tree))) (defun subst-if (new test tree &key key) "Substitutes new for subtrees for which test is true." (labels ((s (subtree) (cond ((funcall test (apply-key key subtree)) new) ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr))))))) (s tree))) (defun subst-if-not (new test tree &key key) "Substitutes new for subtrees for which test is false." (labels ((s (subtree) (cond ((not (funcall test (apply-key key subtree))) new) ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr))))))) (s tree))) (defun nsubst (new old tree &key key (test #'eql testp) (test-not nil notp)) "Substitutes new for subtrees matching old." (labels ((s (subtree) (cond ((satisfies-the-test old subtree) new) ((atom subtree) subtree) (t (do* ((last nil subtree) (subtree subtree (Cdr subtree))) ((atom subtree) (if (satisfies-the-test old subtree) (setf (cdr last) new))) (if (satisfies-the-test old subtree) (return (setf (cdr last) new)) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree))) (defun nsubst-if (new test tree &key key) "Substitutes new for subtrees of tree for which test is true." (labels ((s (subtree) (cond ((funcall test (apply-key key subtree)) new) ((atom subtree) subtree) (t (do* ((last nil subtree) (subtree subtree (Cdr subtree))) ((atom subtree) (if (funcall test (apply-key key subtree)) (setf (cdr last) new))) (if (funcall test (apply-key key subtree)) (return (setf (cdr last) new)) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree))) (defun nsubst-if-not (new test tree &key key) "Substitutes new for subtrees of tree for which test is false." (labels ((s (subtree) (cond ((not (funcall test (apply-key key subtree))) new) ((atom subtree) subtree) (t (do* ((last nil subtree) (subtree subtree (Cdr subtree))) ((atom subtree) (if (not (funcall test (apply-key key subtree))) (setf (cdr last) new))) (if (not (funcall test (apply-key key subtree))) (return (setf (cdr last) new)) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree))) (defun sublis (alist tree &key key (test #'eql) (test-not nil notp)) "Substitutes from alist into tree nondestructively." (declare (inline assoc)) (labels ((s (subtree) (let* ((key-val (apply-key key subtree)) (assoc (if notp (assoc key-val alist :test-not test-not) (assoc key-val alist :test test)))) (cond (assoc (cdr assoc)) ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) (if (and (eq car (car subtreE)) (eq cdr (cdr subtree))) subtree (cons car cdr)))))))) (s tree))) ;;; In run-time env, since can be referenced in line expansions. (defmacro nsublis-macro () (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key subtree))) (if notp (assoc ,key-tmp alist :test-not test-not) (assoc ,key-tmp alist :test test))))) (defun nsublis (alist tree &key key (test #'eql) (test-not nil notp)) "Substitutes new for subtrees matching old." (declare (inline assoc)) (let (temp) (labels ((s (subtree) (cond ((Setq temp (nsublis-macro)) (cdr temp)) ((atom subtree) subtree) (t (do* ((last nil subtree) (subtree subtree (Cdr subtree))) ((atom subtree) (if (setq temp (nsublis-macro)) (setf (cdr last) (cdr temp)))) (if (setq temp (nsublis-macro)) (return (setf (Cdr last) (Cdr temp))) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree)))) ;;;; Functions for using lists as sets (defun member (item list &key key (test #'eql testp) (test-not nil notp)) "Returns tail of list beginning with first element satisfying EQLity, :test, or :test-not with a given item." (do ((list list (cdr list))) ((null list) nil) (let ((car (car list))) (if (satisfies-the-test item car) (return list))))) (defun member-if (test list &key key) "Returns tail of list beginning with first element satisfying test(element)" (do ((list list (Cdr list))) ((endp list) nil) (if (funcall test (apply-key key (car list))) (return list)))) (defun member-if-not (test list &key key) "Returns tail of list beginning with first element not satisfying test(el)" (do ((list list (cdr list))) ((endp list) ()) (if (not (funcall test (apply-key key (car list)))) (return list)))) (defun tailp (object list) "Returns true if Object is the same as some tail of List, otherwise returns false. List must be a proper list or a dotted list." (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) (return t)))) (defun adjoin (item list &key key (test #'eql) (test-not nil notp)) "Add item to list unless it is already a member" (declare (inline member)) (if (let ((key-val (apply-key key item))) (if notp (member key-val list :test-not test-not :key key) (member key-val list :test test :key key))) list (cons item list))) ;;; UNION -- Public. ;;; ;;; This function assumes list2 is the result, adding to it from list1 as ;;; necessary. List2 must initialize the result value, so the call to MEMBER ;;; will apply the test to the elements from list1 and list2 in the correct ;;; order. ;;; (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the union of list1 and list2." (declare (inline member)) (when (and testp notp) (error (intl:gettext "Test and test-not both supplied."))) (let ((res list2)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (push elt res))) res)) ;;; Destination and source are setf-able and many-evaluable. Sets the source ;;; to the cdr, and "conses" the 1st elt of source to destination. ;;; (defmacro steve-splice (source destination) `(let ((temp ,source)) (setf ,source (cdr ,source) (cdr temp) ,destination ,destination temp))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) (let ((res list2) (list1 list1)) (do () ((endp list1)) (if (not (with-set-keys (member (apply-key key (car list1)) list2))) (steve-splice list1 res) (setf list1 (cdr list1)))) res)) (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the intersection of list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) (let ((res nil)) (dolist (elt list1) (if (with-set-keys (member (apply-key key elt) list2)) (push elt res))) res)) (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the intersection of list1 and list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) (let ((res nil) (list1 list1)) (do () ((endp list1)) (if (with-set-keys (member (apply-key key (car list1)) list2)) (steve-splice list1 res) (setq list1 (Cdr list1)))) res)) (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) (if (null list2) list1 (let ((res nil)) (dolist (elt list1) (if (not (with-set-keys (member (apply-key key elt) list2))) (push elt res))) res))) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Destructively returns the elements of list1 which are not in list2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) (let ((res nil) (list1 list1)) (do () ((endp list1)) (if (not (with-set-keys (member (apply-key key (car list1)) list2))) (steve-splice list1 res) (setq list1 (cdr list1)))) res)) (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) (let ((result nil) (key (when key (coerce key 'function))) (test (coerce test 'function)) (test-not (if test-not (coerce test-not 'function) #'eql))) (declare (type (or function null) key) (type function test test-not)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (setq result (cons elt result)))) (let ((test (if testp (lambda (x y) (funcall test y x)) test)) (test-not (if notp (lambda (x y) (funcall test-not y x)) test-not))) (dolist (elt list2) (unless (with-set-keys (member (apply-key key elt) list1)) (setq result (cons elt result))))) result)) ;;; The outer loop examines list1 while the inner loop examines list2. If an ;;; element is found in list2 "equal" to the element in list1, both are ;;; spliced out. When the end of list1 is reached, what is left of list2 is ;;; tacked onto what is left of list1. The splicing operation ensures that ;;; the correct operation is performed depending on whether splice is at the ;;; top of the list or not. (defun nset-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not #'eql notp)) "Destructively return a list with elements which appear but once in LIST1 and LIST2." (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) ;; The outer loop examines LIST1 while the inner loop examines ;; LIST2. If an element is found in LIST2 "equal" to the element ;; in LIST1, both are spliced out. When the end of LIST1 is ;; reached, what is left of LIST2 is tacked onto what is left of ;; LIST1. The splicing operation ensures that the correct ;; operation is performed depending on whether splice is at the ;; top of the list or not. (do ((list1 list1) (list2 list2) (x list1 (cdr x)) (splicex ()) ;; elements of LIST2, which are "equal" to some processed ;; earlier elements of LIST1 (deleted-y ())) ((endp x) (if (null splicex) (setq list1 list2) (rplacd splicex list2)) list1) (let ((key-val-x (apply-key key (car x))) (found-duplicate nil)) ;; Move all elements from LIST2, which are "equal" to (CAR X), ;; to DELETED-Y. (do* ((y list2 next-y) (next-y (cdr y) (cdr y)) (splicey ())) ((endp y)) (cond ((let ((key-val-y (apply-key key (car y)))) (if notp (not (funcall test-not key-val-x key-val-y)) (funcall test key-val-x key-val-y))) (if (null splicey) (setq list2 (cdr y)) (rplacd splicey (cdr y))) (setq deleted-y (rplacd y deleted-y)) (setq found-duplicate t)) (t (setq splicey y)))) (unless found-duplicate (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) (if found-duplicate (if (null splicex) (setq list1 (cdr x)) (rplacd splicex (cdr x))) (setq splicex x))))) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns T if every element in list1 is also in list2." (declare (inline member)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (return-from subsetp nil))) T) ;;; Functions that operate on association lists (defun acons (key datum alist) "Construct a new alist by adding the pair (key . datum) to alist" (cons (cons key datum) alist)) (defun pairlis (keys data &optional (alist '())) "Construct an association list from keys and data (adding to alist)" (do ((x keys (cdr x)) (y data (cdr y))) ((and (endp x) (endp y)) alist) (if (or (endp x) (endp y)) (error (intl:gettext "The lists of keys and data are of unequal length."))) (setq alist (acons (car x) (car y) alist)))) ;;; In run-time environment, since these guys can be inline expanded. (defmacro assoc-guts (test-guy) `(do ((alist alist (cdr alist))) ((endp alist)) (declare (optimize (inhibit-warnings 3))) (if (car alist) (if ,test-guy (return (car alist)))))) (defun assoc (item alist &key key test test-not) "Returns the cons in alist whose car is equal (by a given test or EQL) to the Item." (cond (test (if key (assoc-guts (funcall test item (funcall key (caar alist)))) (assoc-guts (funcall test item (caar alist))))) (test-not (if key (assoc-guts (not (funcall test-not item (funcall key (caar alist))))) (assoc-guts (not (funcall test-not item (caar alist)))))) (t (if key (assoc-guts (eql item (funcall key (caar alist)))) (assoc-guts (eql item (caar alist))))))) (defun assoc-if (predicate alist &key key) "Returns the first cons in alist whose car satisfies the Predicate. If key is supplied, apply it to the car of each cons before testing." (if key (assoc-guts (funcall predicate (funcall key (caar alist)))) (assoc-guts (funcall predicate (caar alist))))) (defun assoc-if-not (predicate alist &key key) "Returns the first cons in alist whose car does not satisfiy the Predicate. If key is supplied, apply it to the car of each cons before testing." (if key (assoc-guts (not (funcall predicate (funcall key (caar alist))))) (assoc-guts (not (funcall predicate (caar alist)))))) (defun rassoc (item alist &key key test test-not) (declare (list alist)) "Returns the cons in alist whose cdr is equal (by a given test or EQL) to the Item." (cond (test (if key (assoc-guts (funcall test item (funcall key (cdar alist)))) (assoc-guts (funcall test item (cdar alist))))) (test-not (if key (assoc-guts (not (funcall test-not item (funcall key (cdar alist))))) (assoc-guts (not (funcall test-not item (cdar alist)))))) (t (if key (assoc-guts (eql item (funcall key (cdar alist)))) (assoc-guts (eql item (cdar alist))))))) (defun rassoc-if (predicate alist &key key) "Returns the first cons in alist whose cdr satisfies the Predicate. If key is supplied, apply it to the cdr of each cons before testing." (if key (assoc-guts (funcall predicate (funcall key (cdar alist)))) (assoc-guts (funcall predicate (cdar alist))))) (defun rassoc-if-not (predicate alist &key key) "Returns the first cons in alist whose cdr does not satisfy the Predicate. If key is supplied, apply it to the cdr of each cons before testing." (if key (assoc-guts (not (funcall predicate (funcall key (cdar alist))))) (assoc-guts (not (funcall predicate (cdar alist)))))) ;;;; Mapping functions. (defun map1 (function original-arglists accumulate take-car) "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. It Maps function over the arglists in the appropriate way. It is done when any of the arglists runs out. Until then, it CDRs down the arglists calling the function and accumulating results as desired." (let* ((arglists (copy-list original-arglists)) (ret-list (list nil)) (temp ret-list)) (do ((res nil) (args '() '())) ((dolist (x arglists nil) (if (null x) (return t))) (if accumulate (cdr ret-list) (car original-arglists))) (do ((l arglists (cdr l))) ((null l)) (push (if take-car (caar l) (car l)) args) (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate (:nconc (setq temp (last (nconc temp res)))) (:list (rplacd temp (list res)) (setq temp (cdr temp))))))) (defun mapc (function list &rest more-lists) "Applies Function to successive elements of each List, and returns its second argument." (map1 function (cons list more-lists) nil t)) (defun mapcar (function list &rest more-lists) "Applies Function to successive elements of each List, and returns a list of results." (map1 function (cons list more-lists) :list t)) (defun mapcan (function list &rest more-lists) "Applies Function to successive elements of each List, and returns NCONC of results." (map1 function (cons list more-lists) :nconc t)) (defun mapl (function list &rest more-lists) "Applies Function to successive CDRs of each List, and returns ()." (map1 function (cons list more-lists) nil nil)) (defun maplist (function list &rest more-lists) "Applies Function to successive CDRs of each List, and returns list of results." (map1 function (cons list more-lists) :list nil)) (defun mapcon (function list &rest more-lists) "Applies Function to successive CDRs of each List, and returns NCONC of results." (map1 function (cons list more-lists) :nconc nil)) ;;; Functions for compatibility sake: (defun memq (item list) "Returns tail of list beginning with first element eq to item" (declare (inline member) (optimize (inhibit-warnings 3))) ; from MEMBER optimizations (member item list :test #'eq)) (defun assq (item alist) "Return the first pair of alist where item EQ the key of pair" (declare (inline assoc)) (assoc item alist :test #'eq)) (defun delq (item list) "Returns list with all elements with all elements EQ to ITEM deleted." (let ((list list)) (do ((x list (cdr x)) (splice '())) ((endp x) list) (cond ((eq item (car x)) (if (null splice) (setq list (cdr x)) (rplacd splice (cdr x)))) (T (setq splice x)))))) ; move splice along to include element cmucl-21a/src/code/load.lisp000066400000000000000000001434371260377556400161060ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/load.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Loader for CMUCL. ;;; Written by Skef Wholey and Rob MacLachlan. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(load *load-verbose* *load-print* *load-truename* *load-pathname*)) (in-package "EXTENSIONS") (export '(*load-if-source-newer* *load-source-types* *load-object-types* invalid-fasl *default-source-external-format*)) (in-package "SYSTEM") (export '(foreign-symbol-address alternate-get-global-address)) (in-package "LISP") ;;;; Variables: ;;; Public: (defvar *load-if-source-newer* :load-object "The default for the :IF-SOURCE-NEWER argument to load.") (declaim (type (member :load-object :load-source :query :compile) *load-if-source-newer*)) (defvar *load-source-types* '("lisp" "l" "cl" "lsp") "The source file types which LOAD recognizes.") (defvar *load-object-types* '(#.(c:backend-fasl-file-type c:*backend*) #.(c:backend-byte-fasl-file-type c:*backend*) "fasl") "A list of the object file types recognized by LOAD.") (defvar *load-lp-object-types* '(#.(string-upcase (c:backend-fasl-file-type c:*backend*)) #.(string-upcase (c:backend-byte-fasl-file-type c:*backend*)) "FASL") "A list of the object file types recognized by LOAD for logical pathnames.") (declaim (list *load-source-types* *load-object-types* *load-lp-object-types*)) (defvar *load-verbose* t "The default for the :VERBOSE argument to Load.") (defvar *load-print* () "The default for the :PRINT argument to Load.") (defvar *load-truename* nil "The TRUENAME of the file that LOAD is currently loading.") (defvar *load-pathname* nil "The defaulted pathname that LOAD is currently loading.") (declaim (type (or pathname null) *load-truename* *load-pathname*)) ;;; Internal state variables: (defvar *load-depth* 0 "Count of the number of recursive loads.") (declaim (type index *load-depth*)) (defvar *fasl-file*) (declaim (type lisp-stream *fasl-file*)) ;; If non-nil, don't check that FASL files loaded into core have the ;; same version number as the current backend. This is used when ;; rebuilding CMUCL after having incremented the FASL-FILE-VERSION ;; parameter. (defvar *skip-fasl-file-version-check* nil) (define-condition invalid-fasl (error) ((filename :reader invalid-fasl-pathname :initarg :file) (fasl-version :reader invalid-fasl-version :initarg :fasl-version) (expected-version :reader invalid-fasl-expected-version :initarg :expected-version)) (:report (lambda (condition stream) (format stream (intl:gettext "~A was compiled for fasl-file version ~X, ~ but this is version ~X") (invalid-fasl-pathname condition) (invalid-fasl-version condition) (invalid-fasl-expected-version condition))))) ;;; LOAD-FRESH-LINE -- internal. ;;; ;;; Output the current number of semicolons after a fresh-line. ;;; (defconstant semicolons ";;;;;;;;;;;;;;;;") ;;; (defun load-fresh-line () (fresh-line) (do ((count *load-depth* (- count (length semicolons)))) ((< count (length semicolons)) (unless (zerop count) (write-string semicolons *standard-output* :end count))) (declare (fixnum count)) (write-string semicolons)) (write-char #\space)) ;;;; The Fop-Table: ;;; ;;; The table is implemented as a simple-vector indexed by the table ;;; offset. We may need to have several, since load can be called recursively. (defvar *free-fop-tables* (list (make-array 1000)) "List of free fop tables for the fasloader.") ;;; The current fop table. (defvar *current-fop-table*) (declaim (simple-vector *current-fop-table*)) ;;; The length of the current fop table. (defvar *current-fop-table-size*) (declaim (type index *current-fop-table-size*)) ;;; Index in the fop-table of the next entry to be used. (defvar *current-fop-table-index*) (declaim (type index *current-fop-table-index*)) (defun grow-fop-table () (let* ((new-size (* *current-fop-table-size* 2)) (new-table (make-array new-size))) (declare (fixnum new-size) (simple-vector new-table)) (replace new-table (the simple-vector *current-fop-table*)) (setq *current-fop-table* new-table) (setq *current-fop-table-size* new-size))) (defmacro push-table (thing) (let ((n-index (gensym))) `(let ((,n-index *current-fop-table-index*)) (declare (fixnum ,n-index)) (when (= ,n-index (the fixnum *current-fop-table-size*)) (grow-fop-table)) (setq *current-fop-table-index* (1+ ,n-index)) (setf (svref *current-fop-table* ,n-index) ,thing)))) ;;;; The Fop-Stack: ;;; ;;; The is also in a simple-vector, but it grows down, since it is somewhat ;;; cheaper to test for overflow that way. ;;; (defvar *fop-stack* (make-array 100) "The fop stack (we only need one!).") (declaim (simple-vector *fop-stack*)) ;;; The index of the most recently pushed item on the fop-stack. (defvar *fop-stack-pointer* 100) ;;; The current index into the fop stack when we last recursively entered ;;; LOAD. (defvar *fop-stack-pointer-on-entry*) (declaim (type index *fop-stack-pointer* *fop-stack-pointer-on-entry*)) (defun grow-fop-stack () (let* ((size (length (the simple-vector *fop-stack*))) (new-size (* size 2)) (new-stack (make-array new-size))) (declare (fixnum size new-size) (simple-vector new-stack)) (replace new-stack (the simple-vector *fop-stack*) :start1 size) (incf *fop-stack-pointer-on-entry* size) (setq *fop-stack-pointer* size) (setq *fop-stack* new-stack))) ;;; With-Fop-Stack -- Internal ;;; ;;; Cache information about the fop-stack in local variables. Define ;;; a local macro to pop from the stack. Push the result of evaluation if ;;; specified. ;;; (defmacro with-fop-stack (pushp &body forms) (let ((n-stack (gensym)) (n-index (gensym)) (n-res (gensym))) `(let ((,n-stack *fop-stack*) (,n-index *fop-stack-pointer*)) (declare (simple-vector ,n-stack) (type index ,n-index)) (macrolet ((pop-stack () `(prog1 (svref ,',n-stack ,',n-index) (setq ,',n-index (1+ ,',n-index)))) (call-with-popped-things (fun n) (let ((n-start (gensym))) `(let ((,n-start (+ ,',n-index ,n))) (declare (type index ,n-start)) (setq ,',n-index ,n-start) (,fun ,@(make-list n :initial-element `(svref ,',n-stack (decf ,n-start)))))))) ,(if pushp `(let ((,n-res (progn ,@forms))) (when (zerop ,n-index) (grow-fop-stack) (setq ,n-index *fop-stack-pointer* ,n-stack *fop-stack*)) (decf ,n-index) (setq *fop-stack-pointer* ,n-index) (setf (svref ,n-stack ,n-index) ,n-res)) `(prog1 (progn ,@forms) (setq *fop-stack-pointer* ,n-index))))))) ;;; FOP database: (defvar fop-codes (make-array 256) "Vector indexed by a FaslOP that yields the FOP's name.") (defvar fop-functions (make-array 256 :initial-element #'(lambda () (error (intl:gettext "Losing FOP!")))) "Vector indexed by a FaslOP that yields a function of 0 arguments which will perform the operation.") (declaim (simple-vector fop-codes fop-functions)) ;;; Define-FOP -- Internal ;;; ;;; Defines Name as a fasl operation, with op-code op. If pushp is :nope, ;;; the body neither pushes or pops the fop stack. If it is nil, then ;;; the body may pop, but the result is ignored. If it is true, the result ;;; is pushed on the stack. ;;; (defmacro define-fop ((name op &optional (pushp t)) &rest forms) `(progn (defun ,name () ,(if (eq pushp :nope) `(progn ,@forms) `(with-fop-stack ,pushp ,@forms))) (setf (svref fop-codes ,op) ',name) (setf (get ',name 'fop-code) ,op) (setf (svref fop-functions ,op) #',name))) ;;; Clone-Fop -- Internal ;;; ;;; Defines a pair of fops which are identical except in that one reads ;;; a four byte argument and the other reads a one byte argument. The ;;; argument can be accessed by using the Clone-Arg macro. ;;; (defmacro clone-fop ((name op &optional (pushp t)) (small-name small-op) &rest forms) `(progn (macrolet ((clone-arg () '(read-arg 4))) (define-fop (,name ,op ,pushp) ,@forms)) (macrolet ((clone-arg () '(read-arg 1))) (define-fop (,small-name ,small-op ,pushp) ,@forms)))) ;;;; Utilities for reading from the fasl file. (declaim (inline read-byte)) ;;; Fast-Read-U-Integer -- Internal ;;; ;;; Expands into code to read an N-byte unsigned integer using ;;; fast-read-byte. ;;; (defmacro fast-read-u-integer (n) (declare (optimize (speed 0))) (do ((res '(fast-read-byte) `(logior (fast-read-byte) (ash ,res 8))) (cnt 1 (1+ cnt))) ((>= cnt n) res))) ;;; Fast-Read-Variable-U-Integer -- Internal ;;; ;;; Like Fast-Read-U-Integer, but the size may be determined at run time. ;;; (defmacro fast-read-variable-u-integer (n) (let ((n-pos (gensym)) (n-res (gensym)) (n-cnt (gensym))) `(do ((,n-pos 8 (+ ,n-pos 8)) (,n-cnt (1- ,n) (1- ,n-cnt)) (,n-res (fast-read-byte) (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) ((zerop ,n-cnt) ,n-res) (declare (type index ,n-pos ,n-cnt))))) ;;; Fast-Read-S-Integer -- Internal ;;; ;;; Read a signed integer. ;;; (defmacro fast-read-s-integer (n) (declare (optimize (speed 0))) (let ((n-last (gensym))) (do ((res `(let ((,n-last (fast-read-byte))) (if (zerop (logand ,n-last #x80)) ,n-last (logior ,n-last #x-100))) `(logior (fast-read-byte) (ash (the (signed-byte ,(* cnt 8)) ,res) 8))) (cnt 1 (1+ cnt))) ((>= cnt n) res)))) ;;; Read-Arg -- Internal ;;; ;;; Read an N-byte unsigned integer from the *fasl-file* ;;; (defmacro read-arg (n) (declare (optimize (speed 0))) (if (= n 1) `(the (unsigned-byte 8) (read-byte *fasl-file*)) `(prepare-for-fast-read-byte *fasl-file* (prog1 (fast-read-u-integer ,n) (done-with-fast-read-byte))))) ;;; Fasload: (defun do-load-verbose (stream) (when *load-verbose* (load-fresh-line) (let ((name (file-name stream))) (if name (format t (intl:gettext "Loading ~S.~%") name) (format t (intl:gettext "Loading stuff from ~S.~%") stream))))) (defun fasload (stream) (when (zerop (file-length stream)) (error (intl:gettext "Attempt to load an empty FASL FILE:~% ~S") (namestring stream))) (do-load-verbose stream) (let* ((*fasl-file* stream) (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) (*current-fop-table-size* (length *current-fop-table*)) (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) (unwind-protect (do ((loaded-group (load-group stream) (load-group stream))) ((not loaded-group))) (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*) (push *current-fop-table* *free-fop-tables*) ;; ;; Nil out the stack and table, so we don't hold onto garbage. (dotimes (i *fop-stack-pointer-on-entry*) (declare (fixnum i)) (setf (svref *fop-stack* i) nil)) (let ((tab *current-fop-table*)) (dotimes (i (length tab)) (declare (fixnum i)) (setf (svref tab i) nil))))) t) #| (defvar *fop-counts* (make-array 256 :initial-element 0)) (defvar *fop-times* (make-array 256 :initial-element 0)) (defvar *print-fops* nil) (defun clear-counts () (fill (the simple-vector *fop-counts*) 0) (fill (the simple-vector *fop-times*) 0) t) (defun analyze-counts () (let ((counts ()) (total-count 0) (times ()) (total-time 0)) (macrolet ((breakdown (lvar tvar vec) `(progn (dotimes (i 255) (declare (fixnum i)) (let ((n (svref ,vec i))) (push (cons (svref fop-codes i) n) ,lvar) (incf ,tvar n))) (setq ,lvar (subseq (sort ,lvar #'(lambda (x y) (> (cdr x) (cdr y)))) 0 10))))) (breakdown counts total-count *fop-counts*) (breakdown times total-time *fop-times*) (format t "Total fop count is ~D~%" total-count) (dolist (c counts) (format t "~30S: ~4D~%" (car c) (cdr c))) (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0)) (dolist (m times) (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) |# ;;; Load-Group -- Internal ;;; ;;; Load-Group returns t if it successfully loads a group from the file, ;;; or () if EOF was encountered while trying to read from the file. ;;; Dispatch to the right function for each fop. Special-case fop-byte-push ;;; since it is real common. ;;; (defun load-group (file) (when (check-header file) (catch 'group-end (let ((*current-fop-table-index* 0)) (loop (let ((byte (read-byte file))) #+debug ; Add :debug to *features* to get a trace of the fops. (let ((ptr *fop-stack-pointer*) (stack *fop-stack*)) (fresh-line *trace-output*) (unless (= ptr (length stack)) (write-char #\space *trace-output*) (prin1 (svref stack ptr) *trace-output*) (terpri *trace-output*)) (prin1 (svref fop-codes byte) *trace-output*) (terpri *trace-output*)) (if (eql byte 3) (let ((index *fop-stack-pointer*)) (declare (type index index)) (when (zerop index) (grow-fop-stack) (setq index *fop-stack-pointer*)) (decf index) (setq *fop-stack-pointer* index) (setf (svref *fop-stack* index) (svref *current-fop-table* (read-byte file)))) (funcall (the function (svref fop-functions byte)))))))))) ;;; Check-Header returns t if it succesfully read a header from the file, ;;; or () if EOF was hit before anything was read. An error is signaled ;;; if garbage is encountered. ;;; ;;; We check that the stream starts with the magic bytes "FASL FILE". ;;; The end of the header is marked by the octet #xFF. (defun check-header (file) (let ((byte (read-byte file NIL '*eof*))) (cond ((eq byte '*eof*) ()) ((eq byte (char-code #\F)) (do ((byte (read-byte file) (read-byte file)) (count 1 (1+ count))) ((= byte 255) t) (declare (fixnum byte count)) (if (and (< count 9) (not (eql byte (char-code (schar "FASL FILE" count))))) (error (intl:gettext "Bad FASL file format."))))) (t (error (intl:gettext "Bad FASL file format.")))))) ;;; Load-S-Integer loads a signed integer Length bytes long from the File. (defun load-s-integer (length) (declare (fixnum length) (optimize (inhibit-warnings 2))) (do* ((index length (1- index)) (byte 0 (read-byte *fasl-file*)) (result 0 (+ result (ash byte bits))) (bits 0 (+ bits 8))) ((= index 0) (if (logbitp 7 byte) ; look at sign bit (- result (ash 1 bits)) result)) (declare (fixnum index byte bits)))) ;;; Sloload: ;;; Something not EQ to anything read from a file: (defconstant load-eof-value '(())) ;;; Sloload loads a text file into the given Load-Package. (defun sloload (stream) (do-load-verbose stream) (do ((sexpr (read stream nil load-eof-value) (read stream nil load-eof-value))) ((eq sexpr load-eof-value)) (if *load-print* (let ((results (multiple-value-list (eval sexpr)))) (load-fresh-line) (format t "~{~S~^, ~}~%" results)) (eval sexpr))) t) ;;; LOAD -- Public ;;; ;;; This function mainly sets up special bindings and then calls ;;; sub-functions. We conditionally bind the switches with PROGV so that ;;; people can set them in their init files and have the values take effect. ;;; If the compiler is loaded, we make the compiler-policy local to LOAD by ;;; binding it to itself. ;;; (defun load (filename &key (verbose nil verbose-p) (print nil print-p) (if-source-newer nil if-source-newer-p) (if-does-not-exist :error) contents (external-format :default)) "Loads the file named by Filename into the Lisp environment. The file type (a.k.a extension) is defaulted if missing. These options are defined: :IF-SOURCE-NEWER If the file type is not specified, and both source and object files exist, then this argument controls which is loaded: :LOAD-OBJECT - load object file (default), :LOAD-SOURCE - load the source file, :COMPILE - compile the source and then load the object file, or :QUERY - ask the user which to load. :IF-DOES-NOT-EXIST {:ERROR | NIL} If :ERROR (the default), signal an error if the file can't be located. If NIL, simply return NIL (LOAD normally returns T.) :VERBOSE {T | NIL} If true (the default), print a line describing each file loaded. :PRINT {T | NIL} If true, print information about loaded values. When loading the source, the result of evaluating each top-level form is printed. :CONTENTS {NIL | :SOURCE | :BINARY} Forces the input to be interpreted as a source or object file, instead of guessing based on the file type. This also inhibits file type defaulting. Probably only necessary if you have source files with a \"fasl\" type. :EXTERNAL-FORMAT The external-format to use when opening the FILENAME. The default is :default which uses the EXT:*DEFAULT-EXTERNAL-FORMAT*. The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER* determine the defaults for the corresponding keyword arguments. These variables are also bound to the specified argument values, so specifying a keyword affects nested loads. The variables EXT:*LOAD-SOURCE-TYPES*, EXT:*LOAD-OBJECT-TYPES*, and EXT:*LOAD-LP-OBJECT-TYPES* determine the file types that we use for defaulting when none is specified." (declare (type (or null (member :source :binary)) contents)) (collect ((vars) (vals)) (macrolet ((frob (wot) `(when ,(concat-pnames wot '-p) (vars ',(intern (format nil "*LOAD-~A*" wot))) (vals ,wot)))) (frob if-source-newer) (frob verbose) (frob print)) (when (boundp 'c::*default-cookie*) (vars 'c::*default-cookie* 'c::*default-interface-cookie*) (vals c::*default-cookie* c::*default-interface-cookie*)) (progv (vars) (vals) (let ((*package* *package*) (*readtable* *readtable*) (*enable-package-locked-errors* *enable-package-locked-errors*) (*load-depth* (1+ *load-depth*)) (intl::*default-domain* intl::*default-domain*)) (values (with-simple-restart (continue (intl:gettext "Return NIL from load of ~S.") filename) (if (streamp filename) (if (or (eq contents :binary) (and (null contents) (equal (stream-element-type filename) '(unsigned-byte 8)))) (fasload filename) (sloload filename)) (let ((pn (merge-pathnames (pathname filename) *default-pathname-defaults* nil))) (if (wild-pathname-p pn) (dolist (file (directory pn) t) (internal-load pn file if-does-not-exist contents external-format)) (let ((tn (probe-file pn))) (if (or tn (pathname-type pn) contents) (internal-load pn tn if-does-not-exist contents external-format) (internal-load-default-type pn if-does-not-exist external-format)))))))))))) ;;; INTERNAL-LOAD -- Internal ;;; ;;; Load the stuff in a file when we have got the name. ;;; (defun internal-load (pathname truename if-does-not-exist contents external-format) (unless truename (return-from internal-load (ecase if-does-not-exist (:error (restart-case (error 'simple-file-error :pathname pathname :format-control (intl:gettext "~S does not exist.") :format-arguments (list (namestring pathname))) (check-again () :report (lambda (stream) (write-string (intl:gettext "See if it exists now.") stream)) (load pathname)) (use-value () :report (lambda (stream) (write-string (intl:gettext "Prompt for a new name."))) (write-string (intl:gettext "New name: ") *query-io*) (force-output *query-io*) (load (read-line *query-io*))))) ((nil) nil)))) (let ((*load-truename* truename) (*load-pathname* pathname)) (case contents (:source (with-open-file (file truename :external-format external-format :direction :input :if-does-not-exist if-does-not-exist) (sloload file))) (:binary (with-open-file (file truename :direction :input :if-does-not-exist if-does-not-exist :element-type '(unsigned-byte 8)) (fasload file))) (t (let ((first-line (with-open-file (file truename :direction :input :external-format :iso8859-1) (read-line file nil)))) (cond ((and first-line (>= (length (the simple-string first-line)) 9) (string= first-line "FASL FILE" :end1 9)) (internal-load pathname truename if-does-not-exist :binary :void)) (t (when (member (pathname-type truename) *load-object-types* :test #'string=) (cerror (intl:gettext "Load it as a source file.") (intl:gettext "File has a fasl file type, but no fasl file header:~% ~S") (namestring truename))) (internal-load pathname truename if-does-not-exist :source external-format)))))))) ;;; TRY-DEFAULT-TYPES -- Internal ;;; (defun try-default-types (pathname types lp-types) (flet ((frob (pathname type) (let* ((pn (make-pathname :type type :defaults pathname)) (tn (probe-file pn))) (values pn tn)))) (dolist (type (if (logical-pathname-p pathname) lp-types types) (values nil nil)) (multiple-value-bind (pn tn) (frob pathname type) (when tn (return (values pn tn))))))) ;;; INTERNAL-LOAD-DEFAULT-TYPE -- Internal ;;; ;;; Handle the case of INTERNAL-LOAD where the file does not exist. ;;; (defun internal-load-default-type (pathname if-does-not-exist external-format) (multiple-value-bind (src-pn src-tn) (try-default-types pathname *load-source-types* '("LISP")) (multiple-value-bind (obj-pn obj-tn) (try-default-types pathname *load-object-types* *load-lp-object-types*) (cond ((and obj-tn src-tn (> (file-write-date src-tn) (file-write-date obj-tn))) (ecase *load-if-source-newer* (:load-object (warn (intl:gettext "Loading object file ~A,~@ which is older than the presumed source:~% ~A.") (namestring obj-tn) (namestring src-tn)) (internal-load obj-pn obj-tn if-does-not-exist :binary :void)) (:load-source (warn (intl:gettext "Loading source file ~A,~@ which is newer than the presumed object file:~% ~A.") (namestring src-tn) (namestring obj-tn)) (internal-load src-pn src-tn if-does-not-exist :source external-format)) (:compile (let ((obj-tn (compile-file src-pn))) (unless obj-tn (error (intl:gettext "Compile of source failed, cannot load object."))) (internal-load src-pn obj-tn :error :binary :void))) (:query (restart-case (error (intl:gettext "Object file ~A is~@ older than the presumed source:~% ~A.") (namestring obj-tn) (namestring src-tn)) (continue () :report (lambda (stream) (write-string (intl:gettext "load source file") stream)) (internal-load src-pn src-tn if-does-not-exist :source external-format)) (load-object () :report (lambda (stream) (write-string (intl:gettext "load object file") stream)) (internal-load src-pn obj-tn if-does-not-exist :binary :void)))))) (obj-tn (internal-load obj-pn obj-tn if-does-not-exist :binary :void)) (src-pn (internal-load src-pn src-tn if-does-not-exist :source external-format)) (t (internal-load pathname nil if-does-not-exist nil external-format)))))) ;;;; Actual FOP definitions: (define-fop (fop-nop 0 :nope)) (define-fop (fop-pop 1 nil) (push-table (pop-stack))) (define-fop (fop-pop-for-effect 65 nil) (pop-stack)) (define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4))) (define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1))) (define-fop (fop-empty-list 4) ()) (define-fop (fop-truth 5) t) (define-fop (fop-misc-trap 66) (%primitive make-other-immediate-type 0 vm:unbound-marker-type)) ;; Not used? (define-fop (fop-character 68) (code-char (read-arg 3))) #-unicode (define-fop (fop-short-character 69) (code-char (read-arg 1))) #+unicode (define-fop (fop-short-character 69) ;; Characters are always little-endian (code-char (+ (read-arg 1) (ash (read-arg 1) 8)))) (clone-fop (fop-struct 48) (fop-small-struct 49) (let* ((size (clone-arg)) (res (%make-instance size))) (declare (type index size)) (do ((n (1- size) (1- n))) ((minusp n)) (declare (type (integer -1 #.most-positive-fixnum) n)) (setf (%instance-ref res n) (pop-stack))) res)) (define-fop (fop-layout 45) (let ((length (pop-stack)) (depth (pop-stack)) (inherits (pop-stack)) (name (pop-stack))) (find-layout name length inherits depth))) (define-fop (fop-end-group 64 :nope) (throw 'group-end t)) (define-fop (fop-end-header 255) (error (intl:gettext "Fop-End-Header was executed???"))) ;;; In the normal loader, we just ignore these. Genesis overwrites ;;; fop-maybe-cold-load with something that knows when to revert to ;;; cold-loading or not. ;;; (define-fop (fop-normal-load 81 :nope)) (define-fop (fop-maybe-cold-load 82 :nope)) (define-fop (fop-verify-table-size 62 :nope) (if (/= *current-fop-table-index* (read-arg 4)) (error (intl:gettext "Fasl table of improper size. Bug!")))) (define-fop (fop-verify-empty-stack 63 :nope) (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*) (error (intl:gettext "Fasl stack not empty. Bug!")))) ;;;; Loading symbols: (defvar *load-symbol-buffer* (make-string 100)) (declaim (simple-string *load-symbol-buffer*)) (defvar *load-symbol-buffer-size* 100) (declaim (type index *load-symbol-buffer-size*)) (macrolet ((frob (name code name-size package) (let ((n-package (gensym "PACKAGE-")) (n-size (gensym "SIZE-")) (n-buffer (gensym "BUFFER-")) (k (gensym "IDX-"))) `(define-fop (,name ,code) (prepare-for-fast-read-byte *fasl-file* (let ((,n-package ,package) (,n-size (fast-read-u-integer ,name-size))) (when (> ,n-size *load-symbol-buffer-size*) (setq *load-symbol-buffer* (make-string (setq *load-symbol-buffer-size* (* ,n-size 2))))) (done-with-fast-read-byte) (let ((,n-buffer *load-symbol-buffer*)) (read-n-bytes *fasl-file* ,n-buffer 0 (* vm:char-bytes ,n-size)) (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) (frob fop-symbol-save 6 4 *package*) (frob fop-small-symbol-save 7 1 *package*) (frob fop-lisp-symbol-save 75 4 *lisp-package*) (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) (frob fop-keyword-symbol-save 77 4 *keyword-package*) (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) (frob fop-symbol-in-package-save 8 4 (svref *current-fop-table* (fast-read-u-integer 4))) (frob fop-small-symbol-in-package-save 9 1 (svref *current-fop-table* (fast-read-u-integer 4))) (frob fop-symbol-in-byte-package-save 10 4 (svref *current-fop-table* (fast-read-u-integer 1))) (frob fop-small-symbol-in-byte-package-save 11 1 (svref *current-fop-table* (fast-read-u-integer 1)))) (clone-fop (fop-uninterned-symbol-save 12) (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) (res (make-string arg))) (read-n-bytes *fasl-file* res 0 (* vm:char-bytes arg)) (push-table (make-symbol res)))) (define-fop (fop-package 14) (let ((name (pop-stack))) (or (find-package name) (error (intl:gettext "The package ~S does not exist.") name)))) ;;;; Loading numbers: (clone-fop (fop-integer 33) (fop-small-integer 34) (load-s-integer (clone-arg))) (define-fop (fop-word-integer 35) (prepare-for-fast-read-byte *fasl-file* (prog1 (fast-read-s-integer 4) (done-with-fast-read-byte)))) (define-fop (fop-byte-integer 36) (prepare-for-fast-read-byte *fasl-file* (prog1 (fast-read-s-integer 1) (done-with-fast-read-byte)))) (define-fop (fop-ratio 70) (let ((den (pop-stack))) (%make-ratio (pop-stack) den))) (define-fop (fop-complex 71) (let ((im (pop-stack))) (%make-complex (pop-stack) im))) (define-fop (fop-complex-single-float 72) (prepare-for-fast-read-byte *fasl-file* (prog1 (complex (make-single-float (fast-read-s-integer 4)) (make-single-float (fast-read-s-integer 4))) (done-with-fast-read-byte)))) (define-fop (fop-complex-double-float 73) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((re-lo (fast-read-u-integer 4)) (re-hi (fast-read-u-integer 4)) (re (make-double-float re-hi re-lo)) (im-lo (fast-read-u-integer 4)) (im-hi (fast-read-u-integer 4)) (im (make-double-float im-hi im-lo))) (complex re im)) (done-with-fast-read-byte)))) #+long-float (define-fop (fop-complex-long-float 67) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((re-lo (fast-read-u-integer 4)) #+sparc (re-mid (fast-read-u-integer 4)) (re-hi (fast-read-u-integer 4)) (re-exp (fast-read-s-integer #+x86 2 #+sparc 4)) (re (make-long-float re-exp re-hi #+sparc re-mid re-lo)) (im-lo (fast-read-u-integer 4)) #+sparc (im-mid (fast-read-u-integer 4)) (im-hi (fast-read-u-integer 4)) (im-exp (fast-read-s-integer #+x86 2 #+sparc 4)) (im (make-long-float im-exp im-hi #+sparc im-mid im-lo))) (complex re im)) (done-with-fast-read-byte)))) (define-fop (fop-single-float 46) (prepare-for-fast-read-byte *fasl-file* (prog1 (make-single-float (fast-read-s-integer 4)) (done-with-fast-read-byte)))) (define-fop (fop-double-float 47) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((lo (fast-read-u-integer 4))) (make-double-float (fast-read-s-integer 4) lo)) (done-with-fast-read-byte)))) #+long-float (define-fop (fop-long-float 52) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((lo (fast-read-u-integer 4)) #+sparc (mid (fast-read-u-integer 4)) (hi (fast-read-u-integer 4)) (exp (fast-read-s-integer #+x86 2 #+sparc 4))) (make-long-float exp hi #+sparc mid lo)) (done-with-fast-read-byte)))) #+double-double (define-fop (fop-double-double-float 67) (prepare-for-fast-read-byte *fasl-file* (prog1 (let ((hi-lo (fast-read-u-integer 4)) (hi-hi (fast-read-s-integer 4)) (lo-lo (fast-read-u-integer 4)) (lo-hi (fast-read-s-integer 4))) (kernel::%make-double-double-float (make-double-float hi-hi hi-lo) (make-double-float lo-hi lo-lo))) (done-with-fast-read-byte)))) #+double-double (define-fop (fop-double-double-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-double-float))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 4)) result)) #+double-double (define-fop (fop-complex-double-double-float 89) (prepare-for-fast-read-byte *fasl-file* (prog1 (let* ((real-hi-lo (fast-read-u-integer 4)) (real-hi-hi (fast-read-s-integer 4)) (real-lo-lo (fast-read-u-integer 4)) (real-lo-hi (fast-read-s-integer 4)) (re (kernel::%make-double-double-float (make-double-float real-hi-hi real-hi-lo) (make-double-float real-lo-hi real-lo-lo))) (imag-hi-lo (fast-read-u-integer 4)) (imag-hi-hi (fast-read-s-integer 4)) (imag-lo-lo (fast-read-u-integer 4)) (imag-lo-hi (fast-read-s-integer 4)) (im (kernel::%make-double-double-float (make-double-float imag-hi-hi imag-hi-lo) (make-double-float imag-lo-hi imag-lo-lo)))) (complex re im)) (done-with-fast-read-byte)))) #+double-double (define-fop (fop-complex-double-double-float-vector 90) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-double-float)))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 8)) result)) ;;;; Loading lists: (define-fop (fop-list 15) (do ((res () (cons (pop-stack) res)) (n (read-arg 1) (1- n))) ((zerop n) res) (declare (type index n)))) (define-fop (fop-list* 16) (do ((res (pop-stack) (cons (pop-stack) res)) (n (read-arg 1) (1- n))) ((zerop n) res) (declare (type index n)))) (macrolet ((frob (name op fun n) `(define-fop (,name ,op) (call-with-popped-things ,fun ,n)))) (frob fop-list-1 17 list 1) (frob fop-list-2 18 list 2) (frob fop-list-3 19 list 3) (frob fop-list-4 20 list 4) (frob fop-list-5 21 list 5) (frob fop-list-6 22 list 6) (frob fop-list-7 23 list 7) (frob fop-list-8 24 list 8) (frob fop-list*-1 25 list* 2) (frob fop-list*-2 26 list* 3) (frob fop-list*-3 27 list* 4) (frob fop-list*-4 28 list* 5) (frob fop-list*-5 29 list* 6) (frob fop-list*-6 30 list* 7) (frob fop-list*-7 31 list* 8) (frob fop-list*-8 32 list* 9)) ;;;; Loading arrays: ;;; (clone-fop (fop-string 37) (fop-small-string 38) (let* ((arg (clone-arg)) (res (make-string arg))) (read-n-bytes *fasl-file* res 0 (* vm:char-bytes arg)) res)) (clone-fop (fop-vector 39) (fop-small-vector 40) (let* ((size (clone-arg)) (res (make-array size))) (declare (fixnum size)) (do ((n (1- size) (1- n))) ((minusp n)) (setf (svref res n) (pop-stack))) res)) (clone-fop (fop-uniform-vector 41) (fop-small-uniform-vector 42) (make-array (clone-arg) :initial-element (pop-stack))) (define-fop (fop-array 83) (let* ((rank (read-arg 4)) (vec (pop-stack)) (length (length vec)) (res (make-array-header vm:simple-array-type rank))) (declare (simple-array vec) (type (unsigned-byte 24) rank)) (set-array-header res vec length nil 0 (do ((i rank (1- i)) (dimensions () (cons (pop-stack) dimensions))) ((zerop i) dimensions) (declare (type index i))) nil) res)) (define-fop (fop-single-float-vector 84) (let* ((length (read-arg 4)) (result (make-array length :element-type 'single-float))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes)) result)) (define-fop (fop-double-float-vector 85) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-float))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2)) result)) #+long-float (define-fop (fop-long-float-vector 88) (let* ((length (read-arg 4)) (result (make-array length :element-type 'long-float))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes #+x86 3 #+sparc 4)) result)) (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex single-float)))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2)) result)) (define-fop (fop-complex-double-float-vector 87) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-float)))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2 2)) result)) #+long-float (define-fop (fop-complex-long-float-vector 89) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex long-float)))) (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes #+x86 3 #+sparc 4 2)) result)) ;;; FOP-INT-VECTOR -- Internal ;;; ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size ;;; must be a directly supported I-vector element size, with no extra bits. ;;; This must be packed according to the local byte-ordering, allowing us to ;;; directly read the bits. ;;; (define-fop (fop-int-vector 43) (prepare-for-fast-read-byte *fasl-file* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size (1 (make-array len :element-type 'bit)) (2 (make-array len :element-type '(unsigned-byte 2))) (4 (make-array len :element-type '(unsigned-byte 4))) (8 (make-array len :element-type '(unsigned-byte 8))) (16 (make-array len :element-type '(unsigned-byte 16))) (32 (make-array len :element-type '(unsigned-byte 32))) (t (error (intl:gettext "Losing i-vector element size: ~S") size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-file* res 0 (ceiling (the index (* size len)) vm:byte-bits)) res))) (define-fop (fop-uniform-int-vector 44) (prepare-for-fast-read-byte *fasl-file* (let* ((n (fast-read-u-integer 4)) (size (fast-read-byte)) (value (fast-read-variable-u-integer (ceiling size 8)))) (done-with-fast-read-byte) (make-array n :element-type `(unsigned-byte ,size) :initial-element value)))) ;;; FOP-SIGNED-INT-VECTOR ;;; ;;; Same as FOP-INT-VECTOR, except this is for signed simple-arrays. ;;; It appears that entry 50 and 51 are clear. (define-fop (fop-signed-int-vector 50) (prepare-for-fast-read-byte *fasl-file* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size (8 (make-array len :element-type '(signed-byte 8))) (16 (make-array len :element-type '(signed-byte 16))) (30 (make-array len :element-type '(signed-byte 30))) (32 (make-array len :element-type '(signed-byte 32))) (t (error (intl:gettext "Losing i-vector element size: ~S") size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-file* res 0 (ceiling (the index (* (if (= size 30) 32 ; Adjust for (signed-byte 30) size) len)) vm:byte-bits)) res))) ;;; Same as fop-uniform-int-vector, but for signed integers (define-fop (fop-uniform-signed-int-vector 51) (prepare-for-fast-read-byte *fasl-file* (let* ((n (fast-read-u-integer 4)) (size (fast-read-byte)) (value (fast-read-variable-u-integer (ceiling size 8)))) (done-with-fast-read-byte) (make-array n :element-type `(signed-byte ,size) :initial-element value)))) (define-fop (fop-eval 53) (let ((result (eval (pop-stack)))) (when *load-print* (load-fresh-line) (prin1 result) (terpri)) result)) (define-fop (fop-eval-for-effect 54 nil) (let ((result (eval (pop-stack)))) (when *load-print* (load-fresh-line) (prin1 result) (terpri)))) (define-fop (fop-funcall 55) (let ((arg (read-arg 1))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) (n arg (1- n))) ((zerop n) (apply (pop-stack) args)) (declare (type index n)))))) (define-fop (fop-funcall-for-effect 56 nil) (let ((arg (read-arg 1))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) (n arg (1- n))) ((zerop n) (apply (pop-stack) args)) (declare (type index n)))))) ;;;; Fixing up circularities. (define-fop (fop-rplaca 200 nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4)) (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) (define-fop (fop-rplacd 201 nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4)) (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) (define-fop (fop-svset 202 nil) (let* ((obi (read-arg 4)) (obj (svref *current-fop-table* obi)) (idx (read-arg 4)) (val (pop-stack))) (if (%instancep obj) (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) (define-fop (fop-structset 204 nil) (setf (%instance-ref (svref *current-fop-table* (read-arg 4)) (read-arg 4)) (pop-stack))) (define-fop (fop-nthcdr 203 t) (nthcdr (read-arg 4) (pop-stack))) ;;;; Loading functions: ;;; must be compatible with the function OPEN-FASL-FILE in compiler/dump.lisp ;;; The old fop-code-format FOP is legacy support for FASL formats prior to ;;; #x18d, which used a single octet for the version number. (clone-fop (fop-long-code-format 157 :nope) (fop-code-format 57) (let ((implementation (read-arg 1)) (version (clone-arg))) (flet ((check-version (imp vers) (when (eql imp implementation) (unless (eql version vers) (cerror (intl:gettext "Load ~A anyway") 'invalid-fasl :file *fasl-file* :fasl-version version :expected-version vers)) t)) (imp-name (imp) (if (< -1 imp (length '#.c:fasl-file-implementations)) (nth imp '#.c:fasl-file-implementations) "unknown machine"))) (unless (or *skip-fasl-file-version-check* (check-version #.(c:backend-fasl-file-implementation c:*backend*) #.(c:backend-fasl-file-version c:*backend*)) (check-version #.(c:backend-byte-fasl-file-implementation c:*backend*) c:byte-fasl-file-version)) (cerror (intl:gettext "Load ~A anyway") (intl:gettext "~A was compiled for a ~A, but this is a ~A") *Fasl-file* (imp-name implementation) (imp-name #.(c:backend-fasl-file-implementation c:*backend*))))))) ;;; Load-Code loads a code object. NItems objects are popped off the stack for ;;; the boxed storage section, then Size bytes of code are read in. ;;; #-(or x86 amd64) (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) (with-fop-stack t (let ((code (%primitive allocate-code-object box-num code-length)) (index (+ #-gengc vm:code-trace-table-offset-slot #+gengc vm:code-debug-info-slot box-num))) (declare (type index index)) #-gengc (setf (%code-debug-info code) (pop-stack)) (dotimes (i box-num) (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop-stack))) (system:without-gcing (read-n-bytes *fasl-file* (code-instructions code) 0 #-gengc code-length #+gengc (* code-length vm:word-bytes))) code))) ;;; Moving native code during a GC or purify is not trivial on the x86 ;;; port, so there are a few options for code placement. ;;; ;;; Byte-compiled code objects can always be moved so can be place in ;;; the dynamics heap. This is enabled with ;;; *load-byte-compiled-code-to-dynamic-space*. ;;; ;;; Native code top level forms only have a short life so can be ;;; safely loaded into the dynamic heap (without fixups) so long as ;;; the GC is not active. This could be handy during a world load to ;;; save core space without the need to enable the support for moving ;;; x86 native code. Enable with *load-x86-tlf-to-dynamic-space*. ;;; ;;; One strategy for allowing the loading of x86 native code into the ;;; dynamic heap requires that the addresses of fixups be saved for ;;; all these code objects. After a purify these fixups can be ;;; dropped. This is enabled with *enable-dynamic-space-code*. ;;; ;;; A little analysis of the header information is used to determine ;;; if a code object is byte compiled, or native code. ;;; (defvar *load-byte-compiled-code-to-dynamic-space* t) (defvar *load-x86-tlf-to-dynamic-space* nil) ; potentially dangerous with CGC. (defvar *load-code-verbose* nil) (defvar *enable-dynamic-space-code* #-gencgc nil #+gencgc t) #+(or x86 amd64) (intl:with-textdomain ("cmucl" "cmucl-x86-vm") (defun load-code (box-num code-length) (declare (fixnum box-num code-length)) (with-fop-stack t (let ((stuff (list (pop-stack)))) (dotimes (i box-num) (declare (fixnum i)) (push (pop-stack) stuff)) (let* ((dbi (car (last stuff))) ; debug-info (tto (first stuff)) ; trace-table-offset (load-to-dynamic-space (or *enable-dynamic-space-code* ;; Definitely Byte compiled code? (and *load-byte-compiled-code-to-dynamic-space* (c::debug-info-p dbi) (not (c::compiled-debug-info-p dbi))) ;; Or a x86 top level form. (and *load-x86-tlf-to-dynamic-space* (c::compiled-debug-info-p dbi) (string= (c::compiled-debug-info-name dbi) (intl:gettext "Top-Level Form"))))) ) (setq stuff (nreverse stuff)) ;; Check that tto is always a list for byte-compiled ;; code. Could be used an alternate check. (when (and (typep tto 'list) (not (and (c::debug-info-p dbi) (not (c::compiled-debug-info-p dbi))))) (format t "* tto list on non-bc code: ~s~% ~s ~s~%" stuff dbi tto)) (when *load-code-verbose* (format t "stuff: ~s~%" stuff) (format t " : ~s ~s ~s ~s~%" (c::compiled-debug-info-p dbi) (c::debug-info-p dbi) (c::compiled-debug-info-name dbi) tto) (if load-to-dynamic-space (format t " Loading to the dynamic space~%") (format t " Loading to the static space~%"))) (let ((code (if load-to-dynamic-space (%primitive allocate-dynamic-code-object box-num code-length) (%primitive allocate-code-object box-num code-length))) (index (+ vm:code-trace-table-offset-slot box-num))) (declare (type index index)) (when *load-code-verbose* (format t " obj addr=~x~%" (kernel::get-lisp-obj-address code))) (setf (%code-debug-info code) (pop stuff)) (dotimes (i box-num) (declare (fixnum i)) (setf (code-header-ref code (decf index)) (pop stuff))) (system:without-gcing (read-n-bytes *fasl-file* (code-instructions code) 0 code-length)) code)))))) (define-fop (fop-code 58 :nope) (load-code (read-arg 4) (read-arg 4))) (define-fop (fop-small-code 59 :nope) (load-code (read-arg 1) (read-arg 2))) (define-fop (fop-fdefinition 60) (fdefinition-object (pop-stack) t)) (define-fop (fop-sanctify-for-execution 61) (let ((component (pop-stack))) (vm:sanctify-for-execution component) component)) ;;; Now a NOOP except in cold load... (define-fop (fop-fset 74 nil) (pop-stack) (pop-stack)) ;;; Modify a slot in a Constants object. ;;; (clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) (code (pop-stack))) (setf (code-header-ref code (clone-arg)) value) (undefined-value))) (define-fop (fop-function-entry 142) (let ((type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) (offset (read-arg 4))) (declare (type index offset)) (unless (zerop (logand offset vm:lowtag-mask)) (error (intl:gettext "Unaligned function object, offset = #x~X.") offset)) (let ((fun (%primitive compute-function code-object offset))) (setf (%function-self fun) fun) (setf (%function-next fun) (%code-entry-points code-object)) (setf (%code-entry-points code-object) fun) (setf (%function-name fun) name) (setf (%function-arglist fun) arglist) (setf (%function-type fun) type) (when *load-print* (load-fresh-line) (format t (intl:gettext "~S defined~%") fun)) fun))) (define-fop (fop-make-byte-compiled-function 143) (let* ((size (read-arg 1)) (layout (pop-stack)) (res (%make-funcallable-instance size layout))) (declare (type index size)) (do ((n (1- size) (1- n))) ((minusp n)) (declare (type (integer -1 #.most-positive-fixnum) n)) (setf (%funcallable-instance-info res n) (pop-stack))) (initialize-byte-compiled-function res) (when *load-print* (load-fresh-line) (format t (intl:gettext "~S defined~%") res)) res)) ;;;; Linkage fixups. ;;; These two variables are initially filled in by Genesis. (defvar *initial-assembler-routines*) (defvar *initial-foreign-symbols*) (defvar *assembler-routines* (make-hash-table :test #'eq)) (defvar *foreign-symbols* (make-hash-table :test #'equal)) (declaim (type hash-table *assembler-routines* *foreign-symbols*)) (defun loader-init () (dolist (routine *initial-assembler-routines*) (setf (gethash (car routine) *assembler-routines*) (cdr routine))) (dolist (symbol *initial-foreign-symbols*) (setf (gethash (car symbol) *foreign-symbols*) (cdr symbol))) (makunbound '*initial-assembler-routines*) (makunbound '*initial-foreign-symbols*) #+linkage-table (foreign-linkage-init)) #-linkage-table (defun foreign-symbol-address-aux (symbol flavor) (declare (ignore flavor)) (multiple-value-bind (value found) (gethash symbol *foreign-symbols* 0) ;; can't make irix linker give values in the symbol table to global vars ;;from dsos, so we have to resolve at runtime (and handle symbols being ;;defined with null values) (if #-irix found #+irix (and found (not (zerop value))) value (let ((value (system:alternate-get-global-address symbol))) (when (zerop value) (error (intl:gettext "Unknown foreign symbol: ~S") symbol)) value)))) (defun foreign-symbol-address (symbol &key (flavor :code)) (let ((maybe-link-table-addr (foreign-symbol-address-aux (vm:extern-alien-name symbol) flavor))) (if (or #-linkage-table t (eq flavor :code)) (int-sap maybe-link-table-addr) ;;; Get address out of linkage table (int-sap (sap-ref-32 (int-sap maybe-link-table-addr) 0))))) (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) (vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-aux sym :code) kind) code-object)) (define-fop (fop-foreign-data-fixup 150) (let* ((kind (pop-stack)) (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) (vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-aux sym :data) kind) code-object)) (define-fop (fop-assembler-code 144) (error (intl:gettext "Cannot load assembler code."))) (define-fop (fop-assembler-routine 145) (error (intl:gettext "Cannot load assembler code."))) (define-fop (fop-assembler-fixup 148) (let ((routine (pop-stack)) (kind (pop-stack)) (code-object (pop-stack))) (multiple-value-bind (value found) (gethash routine *assembler-routines*) (unless found (error (intl:gettext "Undefined assembler routine: ~S") routine)) (vm:fixup-code-object code-object (read-arg 4) value kind)) code-object)) (define-fop (fop-code-object-fixup 149) (let ((kind (pop-stack)) (code-object (pop-stack))) ;; Note: We don't have to worry about GC moving the code-object after ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because ;; we can only use code-object fixups when code-objects don't move. (vm:fixup-code-object code-object (read-arg 4) (get-lisp-obj-address code-object) kind) code-object)) (declaim (maybe-inline read-byte)) cmucl-21a/src/code/loop.lisp000066400000000000000000002642741260377556400161430ustar00rootroot00000000000000;;; -*- Mode: LISP; Package: ANSI-LOOP; Syntax: Common-lisp; Base: 10; Lowercase:T -*- ;;;> ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. ;;;> All Rights Reserved. ;;;> ;;;> Permission to use, copy, modify and distribute this software and its ;;;> documentation for any purpose and without fee is hereby granted, ;;;> provided that the M.I.T. copyright notice appear in all copies and that ;;;> both that copyright notice and this permission notice appear in ;;;> supporting documentation. The names "M.I.T." and "Massachusetts ;;;> Institute of Technology" may not be used in advertising or publicity ;;;> pertaining to distribution of the software without specific, written ;;;> prior permission. Notice must be given in supporting documentation that ;;;> copying distribution is by permission of M.I.T. M.I.T. makes no ;;;> representations about the suitability of this software for any purpose. ;;;> It is provided "as is" without express or implied warranty. ;;;> ;;;> Massachusetts Institute of Technology ;;;> 77 Massachusetts Avenue ;;;> Cambridge, Massachusetts 02139 ;;;> United States of America ;;;> +1-617-253-1000 ;;;> ;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. ;;;> All Rights Reserved. ;;;> ;;;> Permission to use, copy, modify and distribute this software and its ;;;> documentation for any purpose and without fee is hereby granted, ;;;> provided that the Symbolics copyright notice appear in all copies and ;;;> that both that copyright notice and this permission notice appear in ;;;> supporting documentation. The name "Symbolics" may not be used in ;;;> advertising or publicity pertaining to distribution of the software ;;;> without specific, written prior permission. Notice must be given in ;;;> supporting documentation that copying distribution is by permission of ;;;> Symbolics. Symbolics makes no representations about the suitability of ;;;> this software for any purpose. It is provided "as is" without express ;;;> or implied warranty. ;;;> ;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, ;;;> and Zetalisp are registered trademarks of Symbolics, Inc. ;;;> ;;;> Symbolics, Inc. ;;;> 8 New England Executive Park, East ;;;> Burlington, Massachusetts 01803 ;;;> United States of America ;;;> +1-617-221-1000 ;;;> See page 391 of http://bitsavers.trailing-edge.com/pdf/symbolics/software/genera_8/Symbolics_Common_Lisp_Language_Concepts.pdf ;;;> for more information on how to extend loop. ;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ #+cmu (ext:file-comment "$Header: src/code/loop.lisp $") ;;;; LOOP Iteration Macro (in-package :ansi-loop) (intl:textdomain "cmucl") (provide :loop) ;;; Technology. ;;; ;;; The LOOP iteration macro is one of a number of pieces of code ;;; originally developed at MIT and licensed as set out above. This ;;; version of LOOP, which is almost entirely rewritten both as a ;;; clean-up and to conform with the ANSI Lisp LOOP standard, started ;;; life as MIT LOOP version 829 (which was a part of NIL, possibly ;;; never released). ;;; ;;; A "light revision" was performed by Glenn Burke while at Palladian ;;; Software in April 1986, to make the code run in Common Lisp. This ;;; revision was informally distributed to a number of people, and was ;;; sort of the "MIT" version of LOOP for running in Common Lisp. ;;; ;;; A later more drastic revision was performed at Palladian perhaps a ;;; year later. This version was more thoroughly Common Lisp in ;;; style, with a few miscellaneous internal improvements and ;;; extensions. Glenn Burke lost track of this source, apparently ;;; never having moved it to the MIT distribution point; and does not ;;; remember if it was ever distributed. ;;; ;;; This revision for the ANSI standard is based on the code of Glenn ;;; Burke's April 1986 version, with almost everything redesigned ;;; and/or rewritten. ;;; The design of this LOOP is intended to permit, using mostly the same ;;; kernel of code, up to three different "loop" macros: ;;; ;;; (1) The unextended, unextensible ANSI standard LOOP; ;;; ;;; (2) A clean "superset" extension of the ANSI LOOP which provides ;;; functionality similar to that of the old LOOP, but "in the style of" ;;; the ANSI LOOP. For instance, user-definable iteration paths, with a ;;; somewhat cleaned-up interface. ;;; ;;; (3) Extensions provided in another file which can make this LOOP ;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, ;;; with only a small addition of code (instead of two whole, separate, ;;; LOOP macros). ;;; ;;; Each of the above three LOOP variations can coexist in the same LISP ;;; environment. ;;; ;;;; Miscellaneous Environment Things ;;;@@@@The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or ;;; its obvious expansion (prog1 (car x) (setq x (cdr x))). Usually this involves ;;; shifting fenceposts in an iteration or series of carcdr operations. This is ;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's ;;; destructuring setq code. (eval-when (compile load eval) #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*) ) ;;; The uses of this macro are retained in the CL version of loop, in ;;; case they are needed in a particular implementation. Originally ;;; dating from the use of the Zetalisp COPYLIST* function, this is used ;;; in situations where, were cdr-coding in use, having cdr-NIL at the ;;; end of the list might be suboptimal because the end of the list will ;;; probably be RPLACDed and so cdr-normal should be used instead. (defmacro loop-copylist* (l) #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) ;;@@@@Explorer?? #-Genera `(copy-list ,l) ) (defvar *loop-gentemp* nil) (defun loop-gentemp (&optional (pref 'loopvar-)) (if *loop-gentemp* (gensym (string pref)) (gensym))) (defvar *loop-real-data-type* 'real) (defun loop-optimization-quantities (env) ;;@@@@ The ANSI conditionalization here is for those lisps that implement ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). ;; It is really commentary on how this code could be written. I don't ;; actually expect there to be an ANSI #+-conditional -- it should be ;; replaced with the appropriate conditional name for your ;; implementation/dialect. (declare #-ANSI (ignore env) #+Genera (values speed space safety compilation-speed debug)) #+ANSI (let ((stuff (declaration-information 'optimize env))) (values (or (cdr (assoc 'speed stuff)) 1) (or (cdr (assoc 'space stuff)) 1) (or (cdr (assoc 'safety stuff)) 1) (or (cdr (assoc 'compilation-speed stuff)) 1) (or (cdr (assoc 'debug stuff)) 1))) #+CLOE-Runtime (values compiler::time compiler::space compiler::safety compiler::compilation-speed 1) #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) ;;;@@@@ The following form takes a list of variables and a form which presumably ;;; references those variables, and wraps it somehow so that the compiler does not ;;; consider those variables have been referenced. The intent of this is that ;;; iteration variables can be flagged as unused by the compiler, e.g. I in ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage ;;; of it is "invisible" or "not to be considered". ;;;We implicitly assume that a setq does not count as a reference. That is, the ;;; kind of form generated for the above loop construct to step I, simplified, is ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). (defun hide-variable-references (variable-list form) (declare #-Genera (ignore variable-list)) #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) #-Genera form) ;;;@@@@ The following function takes a flag, a variable, and a form which presumably ;;; references that variable, and wraps it somehow so that the compiler does not ;;; consider that variable to have been referenced. The intent of this is that ;;; iteration variables can be flagged as unused by the compiler, e.g. I in ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage ;;; of it is "invisible" or "not to be considered". ;;;We implicitly assume that a setq does not count as a reference. That is, the ;;; kind of form generated for the above loop construct to step I, simplified, is ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). ;;;Certain cases require that the "invisibility" of the reference be conditional upon ;;; something. This occurs in cases of "named" variables (the USING clause). For instance, ;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) ;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is ;;; not referenced. However, if no USING clause is present, we definitely do not ;;; want to be informed that some random gensym is not used. ;;;It is easier for the caller to do this conditionally by passing a flag (which ;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than ;;; for all callers to contain the conditional invisibility construction. (defun hide-variable-reference (really-hide variable form) (declare #-Genera (ignore really-hide variable)) #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns `(compiler:invisible-references (,variable) ,form) form) #-Genera form) ;;;; List Collection Macrology (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) &body body) ;;@@@@ TI? Exploder? #+LISPM (let ((head-place (or user-head-var head-var))) `(let* ((,head-place nil) (,tail-var ,(hide-variable-reference user-head-var user-head-var `(progn #+Genera (scl:locf ,head-place) #-Genera (system:variable-location ,head-place))))) ,@body)) #-LISPM (let ((l (and user-head-var (list (list user-head-var nil))))) #+CLOE `(sys::with-stack-list* (,head-var nil nil) (let ((,tail-var ,head-var) ,@l) ,@body)) #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) ,@body))) (defmacro loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) (declare #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. ) (setq form (macroexpand form env)) (flet ((cdr-wrap (form n) (declare (fixnum n)) (do () ((<= n 4) (setq form `(,(case n (1 'cdr) (2 'cddr) (3 'cdddr) (4 'cddddr)) ,form))) (setq form `(cddddr ,form) n (- n 4))))) (let ((tail-form form) (ncdrs nil)) ;;Determine if the form being constructed is a list of known length. (when (consp form) (cond ((eq (car form) 'list) (setq ncdrs (1- (length (cdr form)))) ;;@@@@ Because the last element is going to be RPLACDed, ;; we don't want the cdr-coded implementations to use ;; cdr-nil at the end (which would just force copying ;; the whole list again). #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) ((member (car form) '(list* cons)) (when (and (cddr form) (member (car (last form)) '(nil 'nil))) (setq ncdrs (- (length (cdr form)) 2)))))) (let ((answer (cond ((null ncdrs) `(when (setf (cdr ,tail-var) ,tail-form) (setq ,tail-var (last (cdr ,tail-var))))) ((< ncdrs 0) (return-from loop-collect-rplacd nil)) ((= ncdrs 0) ;;@@@@ Here we have a choice of two idioms: ;; (rplacd tail (setq tail tail-form)) ;; (setq tail (setf (cdr tail) tail-form)). ;;Genera and most others I have seen do better with the former. `(rplacd ,tail-var (setq ,tail-var ,tail-form))) (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) ncdrs)))))) ;;If not using locatives or something similar to update the user's ;; head variable, we've got to set it... It's harmless to repeatedly set it ;; unconditionally, and probably faster than checking. #-LISPM (when user-head-var (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) answer)))) (defmacro loop-collect-answer (head-var &optional user-head-var) (or user-head-var (progn ;;If we use locatives to get tail-updating to update the head var, ;; then the head var itself contains the answer. Otherwise we ;; have to cdr it. #+LISPM head-var #-LISPM `(cdr ,head-var)))) ;;;; Maximization Technology #| The basic idea of all this minimax randomness here is that we have to have constructed all uses of maximize and minimize to a particular "destination" before we can decide how to code them. The goal is to not have to have any kinds of flags, by knowing both that (1) the type is something which we can provide an initial minimum or maximum value for and (2) know that a MAXIMIZE and MINIMIZE are not being combined. SO, we have a datastructure which we annotate with all sorts of things, incrementally updating it as we generate loop body code, and then use a wrapper and internal macros to do the coding when the loop has been constructed. |# (defstruct (loop-minimax (:constructor make-loop-minimax-internal) (:copier nil) (:predicate nil)) answer-variable type temp-variable flag-variable operations infinity-data) (defvar *loop-minimax-type-infinities-alist* ;;@@@@ This is the sort of value this should take on for a Lisp that has ;; "eminently usable" infinities. n.b. there are neither constants nor ;; printed representations for infinities defined by CL. ;;@@@@ This grotesque read-from-string below is to help implementations ;; which croak on the infinity character when it appears in a token, even ;; conditionalized out. #+Genera '#.(read-from-string "((fixnum most-positive-fixnum most-negative-fixnum) (short-float +1s -1s) (single-float +1f -1f) (double-float +1d -1d) (long-float +1l -1l))") ;;This is how the alist should look for a lisp that has no infinities. In ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. #+(or CLOE-Runtime Minima) '((fixnum most-positive-fixnum most-negative-fixnum) (short-float most-positive-short-float most-negative-short-float) (single-float most-positive-single-float most-negative-single-float) (double-float most-positive-double-float most-negative-double-float) (long-float most-positive-long-float most-negative-long-float)) ;; CMUCL has infinities so let's use them. #+CMU '((fixnum most-positive-fixnum most-negative-fixnum) (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) ;; If we don't know, then we cannot provide "infinite" initial values for any of the ;; types but FIXNUM: #-(or Genera CLOE-Runtime Minima CMU) '((fixnum most-positive-fixnum most-negative-fixnum)) ) (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type :temp-variable (loop-gentemp 'loop-maxmin-temp-) :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) :operations nil :infinity-data infinity-data))) (defun loop-note-minimax-operation (operation minimax) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) operation) (defmacro with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) (which (car (loop-minimax-operations lm))) (infinity-data (loop-minimax-infinity-data lm)) (answer-var (loop-minimax-answer-variable lm)) (temp-var (loop-minimax-temp-variable lm)) (flag-var (loop-minimax-flag-variable lm)) (type (loop-minimax-type lm))) (if flag-var `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) (declare (type ,type ,answer-var ,temp-var)) ,@body) `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) (,temp-var ,init)) (declare (type ,type ,answer-var ,temp-var)) ,@body)))) (defmacro loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) (temp-var (loop-minimax-temp-variable lm)) (flag-var (loop-minimax-flag-variable lm)) (test (hide-variable-reference t (loop-minimax-answer-variable lm) `(,(ecase operation (min '<) (max '>)) ,temp-var ,answer-var)))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) (setq ,@(and flag-var `(,flag-var t)) ,answer-var ,temp-var))))) ;;;; Loop Keyword Tables #| LOOP keyword tables are hash tables string keys and a test of EQUAL. The actual descriptive/dispatch structure used by LOOP is called a "loop universe" contains a few tables and parameterizations. The basic idea is that we can provide a non-extensible ANSI-compatible loop environment, an extensible ANSI-superset loop environment, and (for such environments as CLOE) one which is "sufficiently close" to the old Genera-vintage LOOP for use by old user programs without requiring all of the old LOOP code to be loaded. |# ;;;; Token Hackery ;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, ;;; the second a symbol to check against. (defun loop-tequal (x1 x2) (and (symbolp x1) (string= x1 x2))) (defun loop-tassoc (kwd alist) (and (symbolp kwd) (assoc kwd alist :test #'string=))) (defun loop-tmember (kwd list) (and (symbolp kwd) (member kwd list :test #'string=))) (defun loop-lookup-keyword (loop-token table) (and (symbolp loop-token) (values (gethash (symbol-name loop-token) table)))) (defmacro loop-store-table-data (symbol table datum) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) (defstruct (loop-universe (:print-function print-loop-universe) (:copier nil) (:predicate nil)) keywords ;hash table, value = (fn-name . extra-data). iteration-keywords ;hash table, value = (fn-name . extra-data). for-keywords ;hash table, value = (fn-name . extra-data). path-keywords ;hash table, value = (fn-name . extra-data). type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. ansi ;NIL, T, or :EXTENDED. implicit-for-required ;see loop-hack-iteration ) (defun print-loop-universe (u stream level) (declare (ignore level)) (let ((str (case (loop-universe-ansi u) ((nil) "Non-ANSI") ((t) "ANSI") (:extended "Extended-ANSI") (t (loop-universe-ansi u))))) ;;Cloe could be done with the above except for bootstrap lossage... #+CLOE (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u)) #+(or Genera cmu) ;@@@@ This is reallly the ANSI definition. (print-unreadable-object (u stream :type t :identity t) (princ str stream)) #-(or Genera CLOE cmu) (format stream "#<~S ~A>" (type-of u) str) )) ;;;This is the "current" loop context in use when we are expanding a ;;;loop. It gets bound on each invocation of LOOP. (defvar *loop-universe*) (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords type-keywords type-symbols ansi) #-(and CLOE Source-Bootstrap) (check-type ansi (member nil t :extended)) (flet ((maketable (entries) (let* ((size (length entries)) (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) ht))) (make-loop-universe :keywords (maketable keywords) :for-keywords (maketable for-keywords) :iteration-keywords (maketable iteration-keywords) :path-keywords (maketable path-keywords) :ansi ansi :implicit-for-required (not (null ansi)) :type-keywords (maketable type-keywords) :type-symbols (let* ((size (length type-symbols)) (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) (dolist (x type-symbols) (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) ht)))) ;;;; Setq Hackery (defvar *loop-destructuring-hooks* nil "If not NIL, this must be a list of two things: a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq (list (car frobs) (if (null (cddr frobs)) (cadr frobs) `(prog1 ,(cadr frobs) ,(loop-make-psetq (cddr frobs)))))))) (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) nil (cons (if *loop-destructuring-hooks* (cadr *loop-destructuring-hooks*) 'loop-really-desetq) var-val-pairs))) (defvar *loop-desetq-temporary* (make-symbol "LOOP-DESETQ-TEMP")) (defmacro loop-really-desetq (&environment env &rest var-val-pairs) (labels ((find-non-null (var) ;; see if there's any non-null thing here ;; recurse if the list element is itself a list (do ((tail var)) ((not (consp tail)) tail) (when (find-non-null (pop tail)) (return t)))) (loop-desetq-internal (var val &optional temp) ;; returns a list of actions to be performed (typecase var (null (when (consp val) ;; don't lose possible side-effects (if (eq (car val) 'prog1) ;; these can come from psetq or desetq below. ;; throw away the value, keep the side-effects. ;;Special case is for handling an expanded POP. (mapcan #'(lambda (x) (and (consp x) (or (not (eq (car x) 'car)) (not (symbolp (cadr x))) (not (symbolp (setq x (macroexpand x env))))) (cons x nil))) (cdr val)) `(,val)))) (cons (let* ((car (car var)) (cdr (cdr var)) (car-non-null (find-non-null car)) (cdr-non-null (find-non-null cdr))) (when (or car-non-null cdr-non-null) (if cdr-non-null (let* ((temp-p temp) (temp (or temp *loop-desetq-temporary*)) (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal car `(prog1 (car ,temp) (setq ,temp (cdr ,temp)))) ,@(loop-desetq-internal cdr temp temp)) #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp)) (setq ,temp (cdr ,temp)) ,@(loop-desetq-internal cdr temp temp)))) (if temp-p `(,@(unless (eq temp val) `((setq ,temp ,val))) ,@body) `((let ((,temp ,val)) ,@body)))) ;; no cdring to do (loop-desetq-internal car `(car ,val) temp))))) (otherwise (unless (eq var val) `((setq ,var ,val))))))) (do ((actions)) ((null var-val-pairs) (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) (setq actions (revappend (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) actions))))) ;;;; LOOP-local variables ;;;This is the "current" pointer into the LOOP source code. (defvar *loop-source-code*) ;;;This is the pointer to the original, for things like NAMED that ;;;insist on being in a particular position (defvar *loop-original-source-code*) ;;;This is *loop-source-code* as of the "last" clause. It is used ;;;primarily for generating error messages (see loop-error, loop-warn). (defvar *loop-source-context*) ;;;List of names for the LOOP, supplied by the NAMED clause. (defvar *loop-names*) ;;;The macroexpansion environment given to the macro. (defvar *loop-macro-environment*) ;;;This holds variable names specified with the USING clause. ;;; See LOOP-NAMED-VARIABLE. (defvar *loop-named-variables*) ;;; LETlist-like list being accumulated for one group of parallel bindings. (defvar *loop-variables*) ;;;List of declarations being accumulated in parallel with ;;;*loop-variables*. (defvar *loop-declarations*) ;;;Used by LOOP for destructuring binding, if it is doing that itself. ;;; See loop-make-variable. (defvar *loop-desetq-crocks*) ;;; List of wrapping forms, innermost first, which go immediately inside ;;; the current set of parallel bindings being accumulated in ;;; *loop-variables*. The wrappers are appended onto a body. E.g., ;;; this list could conceivably has as its value ((with-open-file (g0001 ;;; g0002 ...))), with g0002 being one of the bindings in ;;; *loop-variables* (this is why the wrappers go inside of the variable ;;; bindings). (defvar *loop-wrappers*) ;;;This accumulates lists of previous values of *loop-variables* and the ;;;other lists above, for each new nesting of bindings. See ;;;loop-bind-block. (defvar *loop-bind-stack*) ;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause ;;;which inhibits LOOP from actually outputting a type declaration for ;;;an iteration (or any) variable. (defvar *loop-nodeclare*) ;;;This is simply a list of LOOP iteration variables, used for checking ;;;for duplications. (defvar *loop-iteration-variables*) ;;;List of prologue forms of the loop, accumulated in reverse order. (defvar *loop-prologue*) (defvar *loop-before-loop*) (defvar *loop-body*) (defvar *loop-after-body*) ;;;This is T if we have emitted any body code, so that iteration driving ;;;clauses can be disallowed. This is not strictly the same as ;;;checking *loop-body*, because we permit some clauses such as RETURN ;;;to not be considered "real" body (so as to permit the user to "code" ;;;an abnormal return value "in loop"). (defvar *loop-emitted-body*) ;;;List of epilogue forms (supplied by FINALLY generally), accumulated ;;; in reverse order. (defvar *loop-epilogue*) ;;;List of epilogue forms which are supplied after the above "user" ;;;epilogue. "normal" termination return values are provide by putting ;;;the return form in here. Normally this is done using ;;;loop-emit-final-value, q.v. (defvar *loop-after-epilogue*) ;;;The "culprit" responsible for supplying a final value from the loop. ;;;This is so loop-emit-final-value can moan about multiple return ;;;values being supplied. (defvar *loop-final-value-culprit*) ;;;If not NIL, we are in some branch of a conditional. Some clauses may ;;;be disallowed. (defvar *loop-inside-conditional*) ;;;If not NIL, this is a temporary bound around the loop for holding the ;;;temporary value for "it" in things like "when (f) collect it". It ;;;may be used as a supertemporary by some other things. (defvar *loop-when-it-variable*) ;;;Sometimes we decide we need to fold together parts of the loop, but ;;;some part of the generated iteration code is different for the first ;;;and remaining iterations. This variable will be the temporary which ;;;is the flag used in the loop to tell whether we are in the first or ;;;remaining iterations. (defvar *loop-never-stepped-variable*) ;;;List of all the value-accumulation descriptor structures in the loop. ;;; See loop-get-collection-info. (defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) ;;;; Code Analysis Stuff (defun loop-constant-fold-if-possible (form &optional expected-type) #+Genera (declare (values new-form constantp constant-value)) (let ((new-form form) (constantp nil) (constant-value nil)) #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* :repeat t :do-macro-expansion t :do-named-constants t :do-inline-forms t :do-optimizers t :do-constant-folding t :do-function-args t) constantp (constantp new-form *loop-macro-environment*) constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) #-Genera (when (setq constantp (constantp new-form)) (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (typep constant-value expected-type) (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." form constant-value expected-type) (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) (defun loop-constantp (form) #+Genera (constantp form *loop-macro-environment*) #-Genera (constantp form)) ;;;; LOOP Iteration Optimization (defvar *loop-duplicate-code* nil) (defvar *loop-iteration-flag-variable* (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) (multiple-value-bind (speed space) (loop-optimization-quantities env) (+ 40 (* (- speed space) 10)))) (defmacro loop-body (&environment env prologue before-loop main-body after-loop epilogue &aux rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error (intl:gettext "LOOP-BODY called with non-synched before- and after-loop lists."))) ;;All our work is done from these copies, working backwards from the end: (setq rbefore (reverse before-loop) rafter (reverse after-loop)) (labels ((psimp (l) (let ((ans nil)) (dolist (x l) (when x (push x ans) (when (and (consp x) (member (car x) '(go return return-from))) (return nil)))) (nreverse ans))) (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) (makebody () (let ((form `(tagbody ;; ANSI CL 6.1.7.2 says that initially clauses are ;; evaluated in the loop prologue, which precedes ;; all loop code except for the initial settings ;; provided by with, for, or as. ,@(psimp (append (nreverse rbefore) prologue)) next-loop ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) end-loop ,@(psimp epilogue)))) (if flagvar `(let ((,flagvar nil)) ,form) form)))) (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test generated ;; plus once more for the forms that don't need a flag test (do ((threshold (loop-code-duplication-threshold env))) (nil) (declare (fixnum threshold)) ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent ;; forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) ;; The first forms in rbefore & rafter (which are the chronologically ;; last forms in the list) differ, therefore they cannot be moved ;; into the main body. If everything that chronologically precedes ;; them either differs or is equal but is okay to duplicate, we can ;; just put all of rbefore in the prologue and all of rafter after ;; the body. Otherwise, there is something that is not okay to ;; duplicate, so it and everything chronologically after it in ;; rbefore and rafter must go into the body, with a flag test to ;; distinguish the first time around the loop from later times. ;; What chronologically precedes the non-duplicatable form will ;; be handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) ((null bb) (return-from loop-body (makebody))) ;Did it. (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) ((or (not (setq inc (estimate-code-size (car bb) env))) (> (incf count inc) threshold)) ;; Ok, we have found a non-duplicatable piece of code. Everything ;; chronologically after it must be in the central body. ;; Everything chronologically at and after lastdiff goes into the ;; central body under a flag test. (let ((then nil) (else nil)) (do () (nil) (push (pop rbefore) else) (push (pop rafter) then) (when (eq rbefore (cdr lastdiff)) (return))) (unless flagvar (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) main-body)) ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) ;; is the same in rbefore and rafter so just copy it into the body (do () (nil) (pop rafter) (push (pop rbefore) main-body) (when (eq rbefore (cdr bb)) (return))) (return))))))) (defun duplicatable-code-p (expr env) (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of ;; optimize quantities back to help quantify how much code we are willing to ;; duplicate. ans))) (defvar *special-code-sizes* '((return 0) (progn 0) (null 1) (not 1) (eq 1) (car 1) (cdr 1) (when 1) (unless 1) (if 1) (caar 2) (cadr 2) (cdar 2) (cddr 2) (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) (defvar *estimate-code-size-punt* '(block do do* dolist flet labels lambda let let* locally macrolet multiple-value-bind prog prog* symbol-macrolet tagbody unwind-protect with-open-file)) (defun destructuring-size (x) (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) ((atom x) (+ n (if (null x) 0 1))))) (defun estimate-code-size (x env) (catch 'estimate-code-size (estimate-code-size-1 x env))) (defun estimate-code-size-1 (x env) (flet ((list-size (l) (let ((n 0)) (declare (fixnum n)) (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) ;;@@@@ ???? (declare (function list-size (list) fixnum)) (cond ((constantp x #+Genera env) 1) ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) 1))) ((atom x) 1) ;??? self-evaluating??? ((symbolp (car x)) (let ((fn (car x)) (tem nil) (n 0)) (declare (symbol fn) (fixnum n)) (macrolet ((f (overhead &optional (args nil args-p)) `(the fixnum (+ (the fixnum ,overhead) (the fixnum (list-size ,(if args-p args '(cdr x)))))))) (cond ((setq tem (get fn 'estimate-code-size)) (typecase tem (fixnum (f tem)) (t (funcall tem x env)))) ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) #+Genera ((eq fn 'compiler:invisible-references) (list-size (cddr x))) ((eq fn 'cond) (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) ((eq fn 'desetq) (do ((l (cdr x) (cdr l))) ((null l) n) (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) ((member fn '(setq psetq)) (do ((l (cdr x) (cdr l))) ((null l) n) (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) ((eq fn 'go) 1) ((eq fn 'function) ;;This skirts the issue of implementationally-defined lambda macros ;; by recognizing CL function names and nothing else. (if (ext:valid-function-name-p (cadr x)) 1 (throw 'duplicatable-code-p nil))) ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) (throw 'estimate-code-size nil)) (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) (f 3)))))))) (t (throw 'estimate-code-size nil))))) ;;;; Loop Errors (defun loop-context () (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) ((eq l (cdr *loop-source-code*)) (nreverse new)))) (defun loop-error (format-string &rest format-args) #+(or Genera CLOE) (declare (dbg:error-reporter)) #+Genera (setq format-args (copy-list format-args)) ;Don't ask. (kernel:simple-program-error (intl:gettext "~?~%Current LOOP context:~{ ~S~}.") (intl:gettext format-string) format-args (loop-context))) (defun loop-warn (format-string &rest format-args) (warn (intl:gettext "~?~%Current LOOP context:~{ ~S~}.") (intl:gettext format-string) format-args (loop-context))) (defun loop-check-data-type (specified-type required-type &optional (default-type required-type)) (if (null specified-type) default-type (multiple-value-bind (a b) (subtypep specified-type required-type) (cond ((not b) (loop-warn _N"LOOP couldn't verify that ~S is a subtype of the required type ~S." specified-type required-type)) ((not a) (loop-error _N"Specified data type ~S is not a subtype of ~S." specified-type required-type))) specified-type))) ;;;INTERFACE: Traditional, ANSI, Lucid. (defmacro loop-finish () "Causes the iteration to terminate \"normally\", the same as implicit termination by an iteration driving clause, or by use of WHILE or UNTIL -- the epilogue code (if any) will be run, and any implicitly collected result will be returned as the value of the LOOP." '(go end-loop)) (defun subst-gensyms-for-nil (tree) (declare (special *ignores*)) (cond ((null tree) (car (push (loop-gentemp) *ignores*))) ((atom tree) tree) (t (cons (subst-gensyms-for-nil (car tree)) (subst-gensyms-for-nil (cdr tree)))))) (defun loop-build-destructuring-bindings (crocks forms) (if crocks (let ((*ignores* ())) (declare (special *ignores*)) `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) ,(cadr crocks) (declare (ignore ,@*ignores*)) ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) forms)) (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) (*loop-source-context* nil) (*loop-iteration-variables* nil) (*loop-variables* nil) (*loop-nodeclare* nil) (*loop-named-variables* nil) (*loop-declarations* nil) (*loop-desetq-crocks* nil) (*loop-bind-stack* nil) (*loop-prologue* nil) (*loop-wrappers* nil) (*loop-before-loop* nil) (*loop-body* nil) (*loop-emitted-body* nil) (*loop-after-body* nil) (*loop-epilogue* nil) (*loop-after-epilogue* nil) (*loop-final-value-culprit* nil) (*loop-inside-conditional* nil) (*loop-when-it-variable* nil) (*loop-never-stepped-variable* nil) (*loop-names* nil) (*loop-collection-cruft* nil)) (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body ,(nreverse *loop-prologue*) ,(nreverse *loop-before-loop*) ,(nreverse *loop-body*) ,(nreverse *loop-after-body*) ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) (dolist (entry *loop-bind-stack*) (let ((vars (first entry)) (dcls (second entry)) (crocks (third entry)) (wrappers (fourth entry))) (dolist (w wrappers) (setq answer (append w (list answer)))) (when (or vars dcls crocks) (let ((forms (list answer))) ;;(when crocks (push crocks forms)) (when dcls (push `(declare ,@dcls) forms)) (setq answer `(,(cond ((not vars) 'locally) (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) (t 'let)) ,vars ,@(loop-build-destructuring-bindings crocks forms))))))) (if *loop-names* (dolist (name *loop-names* answer) (setq answer `(block ,name ,answer))) `(block nil ,answer))))) (defun loop-iteration-driver () (do () ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) (loop-error _N"~S found where LOOP keyword expected." keyword)) (t (setq *loop-source-context* *loop-source-code*) (loop-pop-source) (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) (apply (symbol-function (first tem)) (rest tem))) ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) (loop-hack-iteration tem)) ((loop-tmember keyword '(and else)) ;; Alternative is to ignore it, ie let it go around to the next keyword... (loop-error _N"Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." keyword (car *loop-source-code*) (cadr *loop-source-code*))) (t (loop-error _N"~S is an unknown keyword in LOOP macro." keyword)))))))) (defun loop-pop-source () (if *loop-source-code* (pop *loop-source-code*) (loop-error _N"LOOP source code ran out when another token was expected."))) (defun loop-get-compound-form () (let ((form (loop-get-form))) (unless (consp form) (loop-error _N"Compound form expected, but found ~A." form)) form)) (defun loop-get-progn () (do ((forms (list (loop-get-compound-form)) (cons (loop-get-compound-form) forms)) (nextform (car *loop-source-code*) (car *loop-source-code*))) ((atom nextform) (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) (defun loop-get-form () (if *loop-source-code* (loop-pop-source) (loop-error _N"LOOP code ran out where a form was expected."))) (defun loop-construct-return (form) `(return-from ,(car *loop-names*) ,form)) (defun loop-pseudo-body (form) (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) (setq *loop-emitted-body* t) (loop-pseudo-body form)) (defun loop-emit-final-value (&optional (form nil form-supplied-p)) (when form-supplied-p (push (loop-construct-return form) *loop-after-epilogue*)) (when *loop-final-value-culprit* (loop-warn _N"LOOP clause is providing a value for the iteration,~@ however one was already established by a ~S clause." *loop-final-value-culprit*)) (setq *loop-final-value-culprit* (car *loop-source-context*))) (defun loop-disallow-conditional (&optional kwd) #+(or Genera CLOE) (declare (dbg:error-reporter)) (when *loop-inside-conditional* (loop-error _N"~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) (defun loop-disallow-anonymous-collectors () (when (find-if-not 'loop-collector-name *loop-collection-cruft*) (loop-error _N"This LOOP clause is not permitted with anonymous collectors."))) (defun loop-disallow-aggregate-booleans () (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) (loop-error _N"This anonymous collection LOOP clause is not permitted with aggregate booleans."))) ;;;; Loop Types (defun loop-typed-init (data-type) (when (and data-type (subtypep data-type 'number)) (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) (coerce 0 data-type) 0))) (defun loop-optional-type (&optional variable) ;;No variable specified implies that no destructuring is permissible. (and *loop-source-code* ;Don't get confused by NILs... (let ((z (car *loop-source-code*))) (cond ((loop-tequal z 'of-type) ;;This is the syntactically unambigous form in that the form of the ;; type specifier does not matter. Also, it is assumed that the ;; type specifier is unambiguously, and without need of translation, ;; a common lisp type specifier or pattern (matching the variable) thereof. (loop-pop-source) (loop-pop-source)) ((symbolp z) ;;This is the (sort of) "old" syntax, even though we didn't used to support all of ;; these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) (when type-spec (loop-pop-source) type-spec))) (t ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, ;; so we will be compulsive (should we really be?) and require that we in fact be ;; doing variable destructuring here. We must translate the old keyword pattern typespec ;; into a fully-specified pattern of real type specifiers here. (if (consp variable) (unless (consp z) (loop-error _N"~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." z)) (loop-error _N"~S found where a LOOP keyword or LOOP type keyword expected." z)) (loop-pop-source) (labels ((translate (k v) (cond ((null k) nil) ((atom k) (replicate (or (gethash k (loop-universe-type-symbols *loop-universe*)) (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) (loop-error _N"Destructuring type pattern ~S contains unrecognized type keyword ~S." z k)) v)) ((atom v) (loop-error _N"Destructuring type pattern ~S doesn't match variable pattern ~S." z variable)) (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) (replicate (typ v) (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) (translate z variable))))))) ;;;; Loop Variables (defun loop-bind-block () (when (or *loop-variables* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) *loop-bind-stack*) (setq *loop-variables* nil *loop-declarations* nil *loop-desetq-crocks* nil *loop-wrappers* nil))) (defun loop-variable-p (name) (do ((entry *loop-bind-stack* (cdr entry))) (nil) (cond ((null entry) (return nil)) ((assoc name (caar entry) :test #'eq) (return t))))) (defun loop-make-variable (name initialization dtype &optional iteration-variable-p) (cond ((null name) (cond ((not (null initialization)) (push (list (setq name (loop-gentemp 'loop-ignore-)) initialization) *loop-variables*) (push `(ignore ,name) *loop-declarations*)))) ((atom name) (cond (iteration-variable-p (if (member name *loop-iteration-variables*) (loop-error _N"Duplicated LOOP iteration variable ~S." name) (push name *loop-iteration-variables*))) ((assoc name *loop-variables*) (loop-error _N"Duplicated variable ~S in LOOP parallel binding." name))) (unless (symbolp name) (loop-error _N"Bad variable ~S somewhere in LOOP." name)) (loop-declare-variable name dtype) ;; We use ASSOC on this list to check for duplications (above), ;; so don't optimize out this list: (push (list name (or initialization (loop-typed-init dtype))) *loop-variables*)) (initialization (cond (*loop-destructuring-hooks* (loop-declare-variable name dtype) (push (list name initialization) *loop-variables*)) (t (let ((newvar (loop-gentemp 'loop-destructure-))) (loop-declare-variable name dtype) (push (list newvar initialization) *loop-variables*) ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. (setq *loop-desetq-crocks* (list* name newvar *loop-desetq-crocks*)) #+ignore (loop-make-variable name nil dtype iteration-variable-p))))) (t (let ((tcar nil) (tcdr nil)) (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype))) (loop-make-variable (car name) nil tcar iteration-variable-p) (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) name) (defun loop-make-iteration-variable (name initialization dtype) (when (and name (loop-variable-p name)) (loop-error _N"Variable ~S has already been used" name)) (loop-make-variable name initialization dtype t)) (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) (let ((dtype #-cmu dtype #+cmu (let ((init (loop-typed-init dtype))) (if (typep init dtype) dtype `(or (member ,init) ,dtype))))) (push `(type ,dtype ,name) *loop-declarations*)))) ((consp name) (cond ((consp dtype) (loop-declare-variable (car name) (car dtype)) (loop-declare-variable (cdr name) (cdr dtype))) (t (loop-declare-variable (car name) dtype) (loop-declare-variable (cdr name) dtype)))) (t (error (intl:gettext "Invalid LOOP variable passed in: ~S.") name)))) (defun loop-maybe-bind-form (form data-type) (if (loop-constantp form) form (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) (defun loop-do-if (for negatep) (let ((form (loop-get-form)) (it-p nil) (first-clause-p t) then else) (let ((*loop-inside-conditional* t)) (flet ((get-clause (for) (do ((body nil)) (nil) (let ((key (car *loop-source-code*)) (*loop-body* nil) data) (cond ((not (symbolp key)) (loop-error _N"~S found where keyword expected getting LOOP clause after ~S." key for)) (t (setq *loop-source-context* *loop-source-code*) (loop-pop-source) (when (and (loop-tequal (car *loop-source-code*) 'it) first-clause-p) (setq *loop-source-code* (cons (or it-p (setq it-p (loop-when-it-variable))) (cdr *loop-source-code*)))) (cond ((or (not (setq data (loop-lookup-keyword key (loop-universe-keywords *loop-universe*)))) (progn (apply (symbol-function (car data)) (cdr data)) (null *loop-body*))) (loop-error _N"~S does not introduce a LOOP clause that can follow ~S." key for)) (t (setq body (nreconc *loop-body* body))))))) (setq first-clause-p nil) (if (loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) (setq then (get-clause for)) (setq else (when (loop-tequal (car *loop-source-code*) :else) (loop-pop-source) (list (get-clause :else))))) (when (loop-tequal (car *loop-source-code*) :end) (loop-pop-source)) (when it-p (setq form `(setq ,it-p ,form)))) (loop-pseudo-body `(if ,(if negatep `(not ,form) form) ,then ,@else)))) (defun loop-do-initially () (loop-disallow-conditional :initially) (push (loop-get-progn) *loop-prologue*)) (defun loop-do-finally () (loop-disallow-conditional :finally) (push (loop-get-progn) *loop-epilogue*)) (defun loop-do-do () (loop-emit-body (loop-get-progn))) (defun loop-do-named () (let ((name (loop-pop-source))) (unless (symbolp name) (loop-error _N"~S is an invalid name for your LOOP." name)) (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) (loop-error _N"The NAMED ~S clause occurs too late." name)) (when *loop-names* (loop-error _N"You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." (car *loop-names*) name)) (setq *loop-names* (list name)))) (defun loop-do-return () (loop-pseudo-body (loop-construct-return (loop-get-form)))) ;;;; Value Accumulation: List (defstruct (loop-collector (:copier nil) (:predicate nil)) name class (history nil) (tempvars nil) dtype (data nil)) ;collector-specific data (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) (name (when (loop-tequal (car *loop-source-code*) 'into) (loop-pop-source) (loop-pop-source)))) (when (not (symbolp name)) (loop-error _N"Value accumulation recipient name, ~S, is not a symbol." name)) (unless name (loop-disallow-aggregate-booleans)) (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (the symbol name) *loop-collection-cruft* :key #'loop-collector-name))) (cond ((not cruft) (when (and name (loop-variable-p name)) (loop-error _N"Variable ~S cannot be used in INTO clause" name)) (push (setq cruft (make-loop-collector :name name :class class :history (list collector) :dtype dtype)) *loop-collection-cruft*)) (t (unless (eq (loop-collector-class cruft) class) (loop-error _N"Incompatible kinds of LOOP value accumulation specified for collecting~@ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." name (car (loop-collector-history cruft)) collector)) (unless (equal dtype (loop-collector-dtype cruft)) (loop-warn _N"Unequal datatypes specified in different LOOP value accumulations~@ into ~S: ~S and ~S." name dtype (loop-collector-dtype cruft)) (when (eq (loop-collector-dtype cruft) t) (setf (loop-collector-dtype cruft) dtype))) (push collector (loop-collector-history cruft)))) (values cruft form)))) (defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) (setq tempvars (list* (loop-gentemp 'loop-list-head-) (loop-gentemp 'loop-list-tail-) (and (loop-collector-name lc) (list (loop-collector-name lc)))))) (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) (unless (loop-collector-name lc) (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) (ecase specifically (list (setq form `(list ,form))) (nconc nil) (append (unless (and (consp form) (eq (car form) 'list)) (setq form `(loop-copylist* ,form))))) (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) ;;;; Value Accumulation: max, min, sum, count. (defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT (multiple-value-bind (lc form) (loop-get-collection-info specifically 'sum default-type) (loop-check-data-type (loop-collector-dtype lc) required-type) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) (setq tempvars (list (loop-make-variable (or (loop-collector-name lc) (loop-gentemp 'loop-sum-)) nil (loop-collector-dtype lc))))) (unless (loop-collector-name lc) (loop-emit-final-value (car (loop-collector-tempvars lc))))) (loop-emit-body (if (eq specifically 'count) `(when ,form (setq ,(car tempvars) ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) `(setq ,(car tempvars) (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) ,form))))))) (defun loop-maxmin-collection (specifically) (multiple-value-bind (lc form) (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) (let ((data (loop-collector-data lc))) (unless data (setf (loop-collector-data lc) (setq data (make-loop-minimax (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) (loop-collector-dtype lc)))) (unless (loop-collector-name lc) (loop-emit-final-value (loop-minimax-answer-variable data)))) (loop-note-minimax-operation specifically data) (push `(with-minimax-value ,data) *loop-wrappers*) (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) ))) ;;;; Value Accumulation: Aggregate Booleans ;;;ALWAYS and NEVER. ;;; Under ANSI these are not permitted to appear under conditionalization. (defun loop-do-always (restrictive negate) (let ((form (loop-get-form))) (when restrictive (loop-disallow-conditional)) (loop-disallow-anonymous-collectors) (loop-emit-body `(,(if negate 'when 'unless) ,form ,(loop-construct-return nil))) (loop-emit-final-value t))) ;;;THERIS. ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) (when restrictive (loop-disallow-conditional)) (loop-disallow-anonymous-collectors) (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) ,(loop-construct-return *loop-when-it-variable*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) (loop-disallow-conditional kwd) (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) (defun loop-do-with () (loop-disallow-conditional :with) (do ((var) (val) (dtype)) (nil) (setq var (loop-pop-source) dtype (loop-optional-type var) val (cond ((loop-tequal (car *loop-source-code*) :=) (loop-pop-source) (loop-get-form)) (t nil))) (when (and var (loop-variable-p var)) (loop-error _N"Variable ~S has already been used" var)) (loop-make-variable var val dtype) (if (loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (return (loop-bind-block))))) ;;;; The iteration driver (defun loop-hack-iteration (entry) (flet ((make-endtest (list-of-forms) (cond ((null list-of-forms) nil) ((member t list-of-forms) '(go end-loop)) (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) (car list-of-forms) (cons 'or list-of-forms)) (go end-loop)))))) (do ((pre-step-tests nil) (steps nil) (post-step-tests nil) (pseudo-steps nil) (pre-loop-pre-step-tests nil) (pre-loop-steps nil) (pre-loop-post-step-tests nil) (pre-loop-pseudo-steps nil) (tem) (data)) (nil) ;; Note we collect endtests in reverse order, but steps in correct ;; order. MAKE-ENDTEST does the nreverse for us. (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) (and (car tem) (push (car tem) pre-step-tests)) (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (when *loop-emitted-body* (loop-error _N"Iteration in LOOP follows body code.")) (unless tem (setq tem data)) (when (car tem) (push (car tem) pre-loop-pre-step-tests)) (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) (unless (loop-tequal (car *loop-source-code*) :and) (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) (make-endtest pre-loop-post-step-tests) (loop-make-psetq pre-loop-steps) (make-endtest pre-loop-pre-step-tests) *loop-before-loop*) *loop-after-body* (list* (loop-make-desetq pseudo-steps) (make-endtest post-step-tests) (loop-make-psetq steps) (make-endtest pre-step-tests) *loop-after-body*)) (loop-bind-block) (return nil)) (loop-pop-source) ; flush the "AND" (when (and (not (loop-universe-implicit-for-required *loop-universe*)) (setq tem (loop-lookup-keyword (car *loop-source-code*) (loop-universe-iteration-keywords *loop-universe*)))) ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. (loop-pop-source) (setq entry tem))))) ;;;; Main Iteration Drivers ;FOR variable keyword ..args.. (defun loop-do-for () (let* ((var (or (loop-pop-source) (loop-gentemp 'loop-do-for-anon-))) (data-type (loop-optional-type var)) (keyword (loop-pop-source)) (first-arg nil) (tem nil)) (setq first-arg (loop-get-form)) (unless (and (symbolp keyword) (setq tem (loop-lookup-keyword keyword (loop-universe-for-keywords *loop-universe*)))) (loop-error _N"~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) (apply (car tem) var first-arg data-type (cdr tem)))) (defun loop-do-repeat () (loop-disallow-conditional :repeat) (let ((form (loop-get-form)) (type 'real)) (let ((var (loop-make-variable (loop-gentemp) form type))) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) ;; FIXME: What should ;; (loop count t into a ;; repeat 3 ;; count t into b ;; finally (return (list a b))) ;; return: (3 3) or (4 3)? PUSHes above are for the former ;; variant, L-P-B below for the latter. #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop)))))) (defun loop-when-it-variable () (or *loop-when-it-variable* (setq *loop-when-it-variable* (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) ;;;; Various FOR/AS Subdispatches ;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN ;;; is omitted (other than being more stringent in its placement), and like ;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first ;;; initialization occurs in the loop body (first-step), not in the variable binding ;;; phase. (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) ;;Then we are the same as "FOR x FIRST y THEN z". (loop-pop-source) `(() (,var ,(loop-get-form)) () () () (,var ,val) () ())) (t ;;We are the same as "FOR x = y". ;; Let me document here what this is returning. Look at ;; loop-hack-iteration for more info. But anyway, we return a list of ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS, ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS, ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add ;; something to make it easier to figure out what these args are!) ;; ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to ;; step the variable VAR with the value VAL. This gets placed in the ;; body of the loop. The original code just did that. It seems that ;; the STEPS form is placed in *loop-before-loop* and in ;; *loop-after-loop*. Loop optimization would then see the same form ;; in both, and move them into the beginning of body. This is ok, ;; except that if there are :initially forms that were placed into the ;; loop prologue, the :initially forms might refer to incorrectly ;; initialized variables, because the optimizer moved STEPS from from ;; *loop-before-loop* into the body. ;; ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical ;; to the STEPS form. This gets placed in *loop-before-loop*. But ;; this won't match any *loop-after-loop* form, so it won't get moved, ;; and we maintain the proper sequencing such that the ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any ;; :initially clauses that might refer to this. So all is well. Whew. ;; ;; I hope this doesn't break anything else. `(() (,var ,val) () () () () () (,var ,val)) ))) (defun loop-for-across (var val data-type) (loop-make-iteration-variable var nil data-type) (let ((vector-var (loop-gentemp 'loop-across-vector-)) (index-var (loop-gentemp 'loop-across-index-))) (multiple-value-bind (vector-form constantp vector-value) (loop-constant-fold-if-possible val 'vector) (loop-make-variable vector-var vector-form (if (and (consp vector-form) (eq (car vector-form) 'the)) (cadr vector-form) 'vector)) #+Genera (push `(system:array-register ,vector-var) *loop-declarations*) (loop-make-variable index-var 0 'fixnum) (let* ((length 0) (length-form (cond ((not constantp) (let ((v (loop-gentemp 'loop-across-limit-))) ;; This used to just push the length ;; computation into the prologue code. I ;; (rtoy) don't think that's right, ;; especially since the prologue is supposed ;; to happen AFTER other initializations. ;; So, this puts the computation in ;; *loop-before-body*. We need a matching ;; entry for *loop-after-body*, so stuff a ;; NIL there. (push `(setq ,v (length ,vector-var)) *loop-before-loop*) (push nil *loop-after-body*) (loop-make-variable v 0 'fixnum))) (t (setq length (length vector-value))))) (first-test `(>= ,index-var ,length-form)) (other-test first-test) (step `(,var (aref ,vector-var ,index-var))) (pstep `(,index-var (1+ ,index-var)))) (declare (fixnum length)) (when constantp (setq first-test (= length 0)) (when (<= length 1) (setq other-test t))) `(,other-test ,step () ,pstep ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) ;;;; List Iteration (defun loop-list-step (listvar) ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used ;; as the stepping function. ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not ;; recognizing FOO may defeat some LOOP optimizations. (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) (loop-pop-source) (loop-get-form)) (t '(function cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) (loop-warn _N"Use of QUOTE around stepping function in LOOP will be left verbatim.") (values `(funcall ,stepper ,listvar) nil)) ((and (consp stepper) (eq (car stepper) 'function)) (values (list (cadr stepper) listvar) (cadr stepper))) (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) ,listvar) nil))))) (defun loop-for-on (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) (t (loop-make-variable (setq listvar (loop-gentemp)) list 't) (loop-make-iteration-variable var nil data-type))) (multiple-value-bind (list-step step-function) (loop-list-step listvar) (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. (let* ((first-endtest (hide-variable-reference (eq var listvar) listvar ;; the following should use `atom' instead of `endp', per ;; [bug2428] `(atom ,listvar))) (other-endtest first-endtest)) (when (and constantp (listp list-value)) (setq first-endtest (null list-value))) (cond ((eq var listvar) ;;Contour of the loop is different because we use the user's variable... `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest () () () ,first-endtest ())) #+LOOP-Prefer-POP ((and step-function (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) (cdddr . 3) (cddddr . 4)))))) (and n (do ((l var (cdr l)) (i 0 (1+ i))) ((atom l) (and (null l) (= i n))) (declare (fixnum i)))))) (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) `(,other-endtest () () ,step ,first-endtest () () ,step))) (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) `(,other-endtest ,step () ,pseudo ,@(and (not (eq first-endtest other-endtest)) `(,first-endtest ,step () ,pseudo))))))))))) (defun loop-for-in (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar (loop-gentemp 'loop-list-))) (loop-make-iteration-variable var nil data-type) (loop-make-variable listvar list 'list) (multiple-value-bind (list-step step-function) (loop-list-step listvar) #-LOOP-Prefer-POP (declare (ignore step-function)) (let* ((first-endtest `(endp ,listvar)) (other-endtest first-endtest) (step `(,var (car ,listvar))) (pseudo-step `(,listvar ,list-step))) (when (and constantp (listp list-value)) (setq first-endtest (null list-value))) #+LOOP-Prefer-POP (when (eq step-function 'cdr) (setq step `(,var (pop ,listvar)) pseudo-step nil)) `(,other-endtest ,step () ,pseudo-step ,@(and (not (eq first-endtest other-endtest)) `(,first-endtest ,step () ,pseudo-step)))))))) ;;;; Iteration Paths (defstruct (loop-path (:copier nil) (:predicate nil)) names preposition-groups inclusive-permitted function user-data) (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) (unless (listp names) (setq names (list names))) ;; Can't do this due to CLOS bootstrapping problems. #-(or Genera (and CLOE Source-Bootstrap)) (check-type universe loop-universe) (let ((ht (loop-universe-path-keywords universe)) (lp (make-loop-path :names (mapcar #'symbol-name names) :function function :user-data user-data :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) lp)) ;;; Note: path functions are allowed to use loop-make-variable, hack ;;; the prologue, etc. (defun loop-for-being (var val data-type) ;; FOR var BEING each/the pathname prep-phrases using-stuff... ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. (let ((path nil) (data nil) (inclusive nil) (stuff nil) (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) ((loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (setq inclusive t) (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) (loop-error _N"~S found where ITS or EACH expected in LOOP iteration path syntax." (car *loop-source-code*))) (loop-pop-source) (setq path (loop-pop-source)) (setq initial-prepositions `((:in ,val)))) (t (loop-error _N"Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) (cond ((not (symbolp path)) (loop-error _N"~S found where a LOOP iteration path name was expected." path)) ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) (loop-error _N"~S is not the name of a LOOP iteration path." path)) ((and inclusive (not (loop-path-inclusive-permitted data))) (loop-error _N"\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) (preps (nconc initial-prepositions (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive (apply fun var data-type preps :inclusive t user-data) (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error _N"Unused USING variables: ~S." *loop-named-variables*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user ;; and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error _N"Value passed back by LOOP iteration path function for path ~S has invalid length." path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) (loop-make-iteration-variable x nil nil) (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) ;;;INTERFACE: Lucid, exported. ;;; i.e., this is part of our extended ansi-loop interface. (defun named-variable (name) (let ((tem (loop-tassoc name *loop-named-variables*))) (declare (list tem)) (cond ((null tem) (values (loop-gentemp) nil)) (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) (prepositional-phrases initial-phrases) (this-group nil nil) (this-prep nil nil) (disallowed-prepositions (mapcan #'(lambda (x) (loop-copylist* (find (car x) preposition-groups :test #'in-group-p))) initial-phrases)) (used-prepositions (mapcar #'car initial-phrases))) ((null *loop-source-code*) (nreverse prepositional-phrases)) (declare (symbol this-prep)) (setq token (car *loop-source-code*)) (dolist (group preposition-groups) (when (setq this-prep (in-group-p token group)) (return (setq this-group group)))) (cond (this-group (when (member this-prep disallowed-prepositions) (loop-error (if (member this-prep used-prepositions) _N"A ~S prepositional phrase occurs multiply for some LOOP clause." _N"Preposition ~S used when some other preposition has subsumed it.") token)) (setq used-prepositions (if (listp this-group) (append this-group used-prepositions) (cons this-group used-prepositions))) (loop-pop-source) (push (list this-prep (loop-get-form)) prepositional-phrases)) ((and USING-allowed (loop-tequal token 'using)) (loop-pop-source) (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) (when (cadr z) (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) (loop-error _N"The variable substitution for ~S occurs twice in a USING phrase,~@ with ~S and ~S." (car z) (cadr z) (cadr tem)) (push (cons (car z) (cadr z)) *loop-named-variables*))) (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) (return nil)))) (t (return (nreverse prepositional-phrases))))))) ;;;; Master Sequencer Function (defun loop-sequencer (indexv indexv-type indexv-user-specified-p variable variable-type sequence-variable sequence-type step-hack default-top prep-phrases) (let ((endform nil) ;Form (constant or variable) with limit value. (sequencep nil) ;T if sequence arg has been provided. (testfn nil) ;endtest function (test nil) ;endtest form. (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. (stepby-constantp t) (step nil) ;step form. (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. (inclusive-iteration nil) ;T if include last index. (start-given nil) ;T when prep phrase has specified start (start-value nil) (start-constantp nil) (limit-given nil) ;T when prep phrase has specified end (limit-constantp nil) (limit-value nil) ) (when variable (loop-make-iteration-variable variable nil variable-type)) (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) (setq prep (caar l) form (cadar l)) (case prep ((:of :in) (setq sequencep t) (loop-make-variable sequence-variable form sequence-type)) ((:from :downfrom :upfrom) (setq start-given t) (cond ((eq prep :downfrom) (setq dir ':down)) ((eq prep :upfrom) (setq dir ':up))) (multiple-value-setq (form start-constantp start-value) (loop-constant-fold-if-possible form indexv-type)) (loop-make-iteration-variable indexv form indexv-type)) ((:upto :to :downto :above :below) (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) ((loop-tequal prep :to) (setq inclusive-iteration t)) ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) ((loop-tequal prep :above) (setq dir ':down)) ((loop-tequal prep :below) (setq dir ':up))) (setq limit-given t) (multiple-value-setq (form limit-constantp limit-value) (loop-constant-fold-if-possible form indexv-type)) (setq endform (if limit-constantp `',limit-value (loop-make-variable (loop-gentemp 'loop-limit-) form indexv-type)))) (:by (multiple-value-setq (form stepby-constantp stepby) (loop-constant-fold-if-possible form indexv-type)) (unless stepby-constantp (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) (t (loop-error _N"~S invalid preposition in sequencing or sequence path.~@ Invalid prepositions specified in iteration path descriptor or something?" prep))) (when (and odir dir (not (eq dir odir))) (loop-error _N"Conflicting stepping directions in LOOP sequencing path")) (setq odir dir)) (when (and sequence-variable (not sequencep)) (loop-error _N"Missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. (unless start-given (loop-make-iteration-variable indexv (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) indexv-type)) (cond ((member dir '(nil :up)) (when (or limit-given default-top) (unless limit-given (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) nil indexv-type) (push `(setq ,endform ,default-top) *loop-prologue*)) (setq testfn (if inclusive-iteration '> '>=))) (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) (t (unless start-given (unless default-top (loop-error _N"Don't know where to start stepping.")) (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) (when (and default-top (not endform)) (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) (when endform (setq testfn (if inclusive-iteration '< '<=))) (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) (when step-hack (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) (let ((first-test test) (remaining-tests test)) (when (and stepby-constantp start-constantp limit-constantp) (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) (setq remaining-tests t))) `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack () () ,first-test ,step-hack)))) ;;;; Interfaces to the Master Sequencer (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer var (loop-check-data-type data-type 'number) t nil nil nil nil nil nil (loop-collect-prepositional-phrases '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) nil (list (list kwd val))))) (defun loop-sequence-elements-path (variable data-type prep-phrases &key fetch-function size-function sequence-type element-type) (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) (let ((sequencev (named-variable 'sequence))) #+Genera (when (and sequencev (symbolp sequencev) sequence-type (subtypep sequence-type 'vector) (not (member (the symbol sequencev) *loop-nodeclare*))) (push `(sys:array-register ,sequencev) *loop-declarations*)) (list* nil nil ; dummy bindings and prologue (loop-sequencer indexv 'fixnum indexv-user-specified-p variable (or data-type element-type) sequencev sequence-type `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) prep-phrases))))) ;;;; Builtin LOOP Iteration Paths #|| (loop for v being the hash-values of ht do (print v)) (loop for k being the hash-keys of ht do (print k)) (loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) (loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) ||# (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) (check-type which (member hash-key hash-value)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error _N"Too many prepositions!")) ((null prep-phrases) (loop-error _N"Missing OF or IN in ~S iteration path."))) (let ((ht-var (loop-gentemp 'loop-hashtab-)) (next-fn (loop-gentemp 'loop-hashtab-next-)) (dummy-predicate-var nil) (post-steps nil)) (multiple-value-bind (other-var other-p) (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) ;;@@@@ named-variable returns a second value of T if the name was actually ;; specified, so clever code can throw away the gensym'ed up variable if ;; it isn't really needed. ;;The following is for those implementations in which we cannot put dummy NILs ;; into multiple-value-setq variable lists. #-Genera (setq other-p t dummy-predicate-var (loop-when-it-variable)) (let* ((key-var nil) (val-var nil) (temp-val-var (loop-gentemp 'loop-hash-val-temp-)) (temp-key-var (loop-gentemp 'loop-hash-key-temp-)) (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-)) (variable (or variable (loop-gentemp))) (bindings `((,variable nil ,data-type) (,ht-var ,(cadar prep-phrases)) ,@(and other-p other-var `((,other-var nil)))))) (if (eq which 'hash-key) (setq key-var variable val-var (and other-p other-var)) (setq key-var (and other-p other-var) val-var variable)) (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (consp key-var) (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) ,@post-steps)) (push `(,key-var nil) bindings)) (when (consp val-var) (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) ,@post-steps)) (push `(,val-var nil) bindings)) `(,bindings ;bindings () ;prologue () ;pre-test () ;parallel steps (not (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var) (,next-fn) ;; We use M-V-BIND instead of M-V-SETQ because we only ;; want to assign values to the key and val vars when we ;; are in the hash table. When we reach the end, ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and ;; temp-val-var. This might break any type declarations ;; on the key and val vars. (when ,temp-predicate-var (setq ,val-var ,temp-val-var) (setq ,key-var ,temp-key-var)) (setq ,dummy-predicate-var ,temp-predicate-var) )) ;post-test ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) (cond ((and prep-phrases (cdr prep-phrases)) (loop-error _N"Too many prepositions!")) ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) (loop-error _N"Unknown preposition ~S" (caar prep-phrases)))) (unless (symbolp variable) (loop-error _N"Destructuring is not valid for package symbol iteration.")) (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) (next-fn (loop-gentemp 'loop-pkgsym-next-)) (variable (or variable (loop-gentemp))) (pkg (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,pkg)) () () () (not (multiple-value-setq (,(progn ;;@@@@ If an implementation can get away without actually ;; using a variable here, so much the better. #+Genera NIL #-Genera (loop-when-it-variable)) ,variable) (,next-fn))) ()))) ;; Supports ;; ;; (loop for cp being the codepoint of string ...) ;; ;; where cp is the codepoint of charactor (or surrogate pair) in the ;; string. (defun loop-string-codepoint-iteration-path (variable data-type prep-phrases) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error _N"Too many prepositions!")) ((null prep-phrases) (loop-error _N"Missing OF or IN in ~S iteration path."))) (unless (symbolp variable) (loop-error _N"Destructuring is not valid for string codepoint iteration.")) (let ((string-var (loop-gentemp 'loop-codepoint-string-)) (next-fn (loop-gentemp 'loop-codepoint-next-)) (post-steps nil)) (let* ((val-var nil) (temp-val-var (loop-gentemp 'loop-codepoint-val-temp-)) (temp-predicate-var (loop-gentemp 'loop-codepoint-predicate-var-)) (variable (or variable (loop-gentemp))) (bindings `((,variable nil ,data-type) (,string-var ,(cadar prep-phrases))))) (push `(lisp::with-string-codepoint-iterator (,next-fn ,string-var)) *loop-wrappers*) (setq val-var variable) `(,bindings ;bindings () ;prologue () ;pre-test () ;parallel steps (not (multiple-value-bind (,temp-predicate-var ,temp-val-var) (,next-fn) (when ,temp-predicate-var (setq ,val-var ,temp-val-var)) ,temp-predicate-var )) ;post-test ,post-steps)))) ;; Supports ;; (loop for g-string being the glyph of string ...) ;; ;; where g-string is a string consisting of a character and all ;; trailing combining characters. (defun loop-string-glyph-string-iteration-path (variable data-type prep-phrases) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error _N"Too many prepositions!")) ((null prep-phrases) (loop-error _N"Missing OF or IN in ~S iteration path."))) (unless (symbolp variable) (loop-error _N"Destructuring is not valid for string glyph iteration.")) (let ((string-var (loop-gentemp 'loop-glyph-string-)) (next-fn (loop-gentemp 'loop-glyph-next-)) (post-steps nil)) (let* ((val-var nil) (temp-index-var (loop-gentemp 'loop-glyph-index-temp-)) (temp-len-var (loop-gentemp 'loop-glyph-len-temp-)) (temp-predicate-var (loop-gentemp 'loop-glyph-predicate-var-)) (variable (or variable (loop-gentemp))) (bindings `((,variable nil ,data-type) (,string-var ,(cadar prep-phrases))))) (push `(lisp::with-string-glyph-iterator (,next-fn ,string-var)) *loop-wrappers*) (setq val-var variable) `(,bindings ;bindings () ;prologue () ;pre-test () ;parallel steps (not (multiple-value-bind (,temp-predicate-var ,temp-index-var ,temp-len-var) (,next-fn) (when ,temp-predicate-var (setq ,val-var (subseq ,string-var ,temp-index-var ,temp-len-var))) ,temp-predicate-var )) ;post-test ,post-steps)))) ;;;; ANSI Loop (defun make-ansi-loop-universe (extended-p) (let ((w (make-standard-loop-universe :keywords `((named (loop-do-named)) (initially (loop-do-initially)) (finally (loop-do-finally)) (do (loop-do-do)) (doing (loop-do-do)) (return (loop-do-return)) (collect (loop-list-collection list)) (collecting (loop-list-collection list)) (append (loop-list-collection append)) (appending (loop-list-collection append)) (nconc (loop-list-collection nconc)) (nconcing (loop-list-collection nconc)) (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) (counting (loop-sum-collection count ,*loop-real-data-type* fixnum)) (sum (loop-sum-collection sum number number)) (summing (loop-sum-collection sum number number)) (maximize (loop-maxmin-collection max)) (minimize (loop-maxmin-collection min)) (maximizing (loop-maxmin-collection max)) (minimizing (loop-maxmin-collection min)) (always (loop-do-always t nil)) ; Normal, do always (never (loop-do-always t t)) ; Negate the test on always. (thereis (loop-do-thereis t)) (while (loop-do-while nil :while)) ; Normal, do while (until (loop-do-while t :until)) ; Negate the test on while (when (loop-do-if when nil)) ; Normal, do when (if (loop-do-if if nil)) ; synonymous (unless (loop-do-if unless t)) ; Negate the test on when (with (loop-do-with)) (repeat (loop-do-repeat))) :for-keywords '((= (loop-ansi-for-equals)) (across (loop-for-across)) (in (loop-for-in)) (on (loop-for-on)) (from (loop-for-arithmetic :from)) (downfrom (loop-for-arithmetic :downfrom)) (upfrom (loop-for-arithmetic :upfrom)) (below (loop-for-arithmetic :below)) (above (loop-for-arithmetic :above)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) (downto (loop-for-arithmetic :downto)) (by (loop-for-arithmetic :by)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) (as (loop-do-for))) :type-symbols '(array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string base-char symbol t vector) :type-keywords nil :ansi (if extended-p :extended t)))) (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:which hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:which hash-value)) (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:internal :external :inherited))) (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:external))) (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:internal :external))) (when extended-p (add-loop-path '(code-point code-points codepoint codepoints) 'loop-string-codepoint-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil) (add-loop-path '(glyph glyphs) 'loop-string-glyph-string-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil)) w)) (defparameter *loop-ansi-universe* (make-ansi-loop-universe t)) (defun loop-standard-expansion (keywords-and-forms environment universe) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) (let ((tag (gensym))) `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) ;;;INTERFACE: ANSI (defmacro loop (&environment env &rest keywords-and-forms) #+Genera (declare (compiler:do-not-record-macroexpansions) (zwei:indentation . zwei:indent-loop)) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) #+allegro (defun excl::complex-loop-expander (body env) (loop-standard-expansion body env *loop-ansi-universe*)) cmucl-21a/src/code/mach-os.lisp000066400000000000000000000047141260377556400165100ustar00rootroot00000000000000;;; -*- Package: SYSTEM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/mach-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMU CL under Mach. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. ;;; (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(get-system-info get-page-size os-init)) (export '(*task-self* *task-data* *task-notify*)) (pushnew :mach *features*) (setq *software-type* "MACH/4.3BSD") (defun software-version () "Returns a string describing version of the supporting software." (string-trim '(#\newline) (with-output-to-string (stream) (run-program "/usr/cs/etc/version" ; Site dependent??? nil :output stream)))) ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions ;;; that set up the argument blocks for the server interfaces. (defvar *task-self*) (defun os-init () (setf *task-self* (mach:mach-task_self)) #+sparc ;; Can't use #x20000000 thru #xDFFFFFFF, but mach tries to let us. (system:allocate-system-memory-at (system:int-sap #x20000000) #xc0000000)) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. For ;;; page-faults, we add pagein and pageout, since that is a somewhat more ;;; interesting number than the total faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt majflt)) (unless err? (error "Unix system call getrusage failed: ~A." (unix:get-unix-error-msg utime))) (multiple-value-bind (gr ps fc ac ic wc zf ra in ot) (mach:vm_statistics *task-self*) (declare (ignore ps fc ac ic wc zf ra)) (mach:gr-error 'mach:vm_statistics gr) (values utime stime (+ in ot))))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (mach:gr-call* mach:vm_statistics *task-self*)) cmucl-21a/src/code/mach.lisp000066400000000000000000000113171260377556400160660ustar00rootroot00000000000000;;; -*- Package: MACH -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/mach.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the low-level support for MACH features not found ;;; in UNIX. ;;; (in-package "MACH") (use-package "ALIEN") (use-package "C-CALL") (use-package "SYSTEM") (intl:textdomain "cmucl") (export '(port mach-task_self mach-task_data mach-task_notify kern-success get-mach-error-msg gr-error gr-call gr-call* gr-bind vm_allocate vm_copy vm_deallocate vm_statistics)) ;;;; Standard ports. (def-alien-type port int) (def-alien-routine ("task_self" mach-task_self) port) (def-alien-routine ("thread_reply" mach-task_data) port) (def-alien-routine ("task_notify" mach-task_notify) port) ;;;; Return codes. (def-alien-type kern-return int) (defconstant kern-success 0) (defconstant kern-invalid-address 1) (defconstant kern-protection-failure 2) (defconstant kern-no-space 3) (defconstant kern-invalid-argument 4) (defconstant kern-failure 5) (defconstant kern-resource-shortage 6) (defconstant kern-not-receiver 7) (defconstant kern-no-access 8) (defconstant kern-memory-failure 9) (defconstant kern-memory-error 10) (defconstant kern-already-in-set 11) (defconstant kern-not-in-set 12) (defconstant kern-name-exists 13) (defconstant kern-aborted 14) (defconstant kern-memory-present 23) (def-alien-routine ("mach_error_string" get-mach-error-msg) c-string (errno kern-return)) ;;; GR-Error -- Public ;;; (defun gr-error (function gr &optional context) "Signal an error indicating that Function returned code GR. If the code is success, then do nothing." (unless (eql gr kern-success) (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr)))) ;;; GR-Call -- Public ;;; (defmacro gr-call (fun &rest args) "GR-Call Function {Arg}* Call the function with the specified Args and signal an error if the first value returned is not mach:kern-success. Nil is returned." (let ((n-gr (gensym))) `(let ((,n-gr (,fun ,@args))) (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))))) ;;; GR-Call* -- Public ;;; (defmacro gr-call* (fun &rest args) "GR-Call* Function {Arg}* Call the function with the specified Args and signal an error if the first value returned is not mach:kern-success. The second value is returned." (let ((n-gr (gensym)) (n-res (gensym))) `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args) (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)) ,n-res))) ;;; GR-Bind -- Public ;;; (defmacro gr-bind (vars (fun . args) &parse-body (body decls)) "GR-Bind ({Var}*) (Function {Arg}*) {Form}* Call the function with the specified Args and signal an error if the first value returned is not mach:Kern-Success. If the call succeeds, the Forms are evaluated with remaining return values bound to the Vars." (let ((n-gr (gensym))) `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args) ,@decls (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)) ,@body))) ;;;; VM routines. (export '(vm_allocate vm_copy vm_deallocate vm_statistics)) (def-alien-routine ("vm_allocate" vm_allocate) int (task port) (address system-area-pointer :in-out) (size unsigned-long) (anywhere boolean)) (def-alien-routine ("vm_copy" vm_copy) int (task port) (source system-area-pointer) (count unsigned-long) (dest system-area-pointer)) (def-alien-routine ("vm_deallocate" vm_deallocate) int (task port) (address system-area-pointer) (size unsigned-long)) (def-alien-type nil (struct vm_statistics (pagesize long) (free_count long) (active_count long) (inactive_count long) (wire_count long) (zero_fill_count long) (reactivations long) (pageins long) (pageouts long) (faults long) (cow_faults long) (lookups long) (hits long))) (defun vm_statistics (task) (with-alien ((vm_stats (struct vm_statistics))) (values (alien-funcall (extern-alien "vm_statistics" (function int port (* (struct vm_statistics)))) task (alien-sap vm_stats)) (slot vm_stats 'pagesize) (slot vm_stats 'free_count) (slot vm_stats 'active_count) (slot vm_stats 'inactive_count) (slot vm_stats 'wire_count) (slot vm_stats 'zero_fill_count) (slot vm_stats 'reactivations) (slot vm_stats 'pageins) (slot vm_stats 'pageouts) (slot vm_stats 'faults) (slot vm_stats 'cow_faults) (slot vm_stats 'lookups) (slot vm_stats 'hits)))) cmucl-21a/src/code/machdef.lisp000066400000000000000000000042071260377556400165450ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Mach -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/machdef.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Record definitions needed for the interface to Mach. ;;; (in-package "MACH") (intl:textdomain "cmucl") (export '(msg-simplemsg msg-msgsize msg-msgtype msg-localport msg-remoteport msg-id sigmask with-trap-arg-block)) (export '(int-array int-array-ref)) (def-c-type c-string (pointer simple-base-string)) (defrecord Msg (Reserved1 (unsigned-byte 8) 8) (Reserved2 (unsigned-byte 8) 8) (Reserved3 (unsigned-byte 8) 8) (Reserved4 (unsigned-byte 7) 7) (SimpleMsg boolean 1) (MsgSize (signed-byte 32) 32) (MsgType (signed-byte 32) 32) (LocalPort port 32) (RemotePort port 32) (ID (signed-byte 32) 32)) (defrecord timeval (seconds (unsigned-byte 32) (long-words 1)) (useconds (signed-byte 32) (long-words 1))) (defrecord timezone (minuteswest (signed-byte 32) (long-words 1)) (dsttime (signed-byte 32) (long-words 1))) (def-c-array int-array unsigned-long 32) (eval-when (compile load eval) (defrecord tchars (intrc (signed-byte 8) (bytes 1)) (quitc (signed-byte 8) (bytes 1)) (startc (signed-byte 8) (bytes 1)) (stopc (signed-byte 8) (bytes 1)) (eofc (signed-byte 8) (bytes 1)) (brkc (signed-byte 8) (bytes 1))) (defrecord ltchars (suspc (signed-byte 8) (bytes 1)) (dsuspc (signed-byte 8) (bytes 1)) (rprntc (signed-byte 8) (bytes 1)) (flushc (signed-byte 8) (bytes 1)) (werasc (signed-byte 8) (bytes 1)) (lnextc (signed-byte 8) (bytes 1))) ); eval-when (compile load eval) (defmacro with-trap-arg-block (type var &body forms) `(with-stack-alien (,var ,type (record-size ',type)) ,@forms)) ;;; SIGMASK -- Public ;;; (defmacro sigmask (&rest signals) "Returns a mask given a set of signals." (apply #'logior (mapcar #'(lambda (signal) (ash 1 (1- (unix-signal-number signal)))) signals))) cmucl-21a/src/code/macros.lisp000066400000000000000000002172621260377556400164510ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/macros.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the macros that are part of the standard ;;; Spice Lisp environment. ;;; ;;; Written by Scott Fahlman and Rob MacLachlan. ;;; Modified by Bill Chiles to adhere to the wall. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(defvar defparameter defconstant when unless setf defsetf psetf shiftf rotatef push pushnew pop incf decf remf case typecase with-open-file with-open-stream with-input-from-string with-output-to-string locally etypecase ctypecase ecase ccase get-setf-expansion define-setf-expander define-modify-macro destructuring-bind nth-value otherwise ; Sacred to CASE and related macros. define-compiler-macro)) (in-package "EXTENSIONS") (export '(do-anonymous collect iterate)) (in-package "LISP") ;;; Parse-Body -- Public ;;; ;;; Parse out declarations and doc strings, *not* expanding macros. ;;; Eventually the environment arg should be flushed, since macros can't expand ;;; into declarations anymore. ;;; (defun parse-body (body environment &optional (doc-string-allowed t)) "This function is to parse the declarations and doc-string out of the body of a defun-like form. Body is the list of stuff which is to be parsed. Environment is ignored. If Doc-String-Allowed is true, then a doc string will be parsed out of the body and returned. If it is false then a string will terminate the search for declarations. Three values are returned: the tail of Body after the declarations and doc strings, a list of declare forms, and the doc-string, or NIL if none." (declare (ignore environment)) (let ((decls ()) (doc nil)) (do ((tail body (cdr tail))) ((endp tail) (values tail (nreverse decls) doc)) (let ((form (car tail))) (cond ((and (stringp form) (cdr tail)) (if doc-string-allowed (setq doc form ;; Only one doc string is allowed. doc-string-allowed nil) (return (values tail (nreverse decls) doc)))) ((not (and (consp form) (symbolp (car form)))) (return (values tail (nreverse decls) doc))) ((eq (car form) 'declare) (push form decls)) (t (return (values tail (nreverse decls) doc)))))))) ;;;; DEFMACRO: ;;; Defmacro -- Public ;;; ;;; Parse the definition and make an expander function. The actual ;;; definition is done by %defmacro which we expand into. ;;; (defmacro defmacro (name lambda-list &body body) (when lisp::*enable-package-locked-errors* (multiple-value-bind (valid block-name) (ext:valid-function-name-p name) (declare (ignore valid)) (let ((package (symbol-package block-name))) (when package (when (ext:package-definition-lock package) (restart-case (error 'lisp::package-locked-error :package package :format-control (intl:gettext "defining macro ~A") :format-arguments (list name)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable the package's definition-lock then continue") stream)) (setf (ext:package-definition-lock package) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Unlock all packages, then continue") stream)) (lisp::unlock-all-packages)))))))) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro lambda-list whole body name 'defmacro :environment environment) (when doc (intl::note-translatable intl::*default-domain* doc)) (let ((def `(lambda (,whole ,environment) ,@local-decs (block ,name ,body)))) `(progn (eval-when (:compile-toplevel) (c::do-macro-compile-time ',name #',def)) (eval-when (:load-toplevel :execute) (c::%defmacro ',name #',def ',lambda-list ,doc))))))) ;;; %Defmacro, %%Defmacro -- Internal ;;; ;;; Defmacro expands into %Defmacro which is a function that is treated ;;; magically the compiler. After the compiler has gotten the information it ;;; wants out of macro definition, it compiles a call to %%Defmacro which ;;; happens at load time. We have a %Defmacro function which just calls ;;; %%Defmacro in order to keep the interpreter happy. ;;; ;;; Eventually %%Defmacro should deal with clearing old compiler information ;;; for the functional value. ;;; (defun c::%defmacro (name definition lambda-list doc) (assert (eval:interpreted-function-p definition)) (setf (eval:interpreted-function-name definition) name) (setf (eval:interpreted-function-arglist definition) lambda-list) (c::%%defmacro name definition doc)) ;;; (defun c::%%defmacro (name definition doc) (clear-info function where-from name) (setf (macro-function name) definition) (setf (documentation name 'function) doc) name) ;;;; DEFINE-COMPILER-MACRO (defmacro define-compiler-macro (name lambda-list &body body) "Define a compiler-macro for NAME." (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (validp block-name) (valid-function-name-p name) (unless validp (simple-program-error (intl:gettext "~S is not a valid function name.") name)) (multiple-value-bind (body local-decs doc) (parse-defmacro lambda-list whole body name 'define-compiler-macro :environment environment) (when doc (intl::note-translatable intl::*default-domain* doc)) (let ((def `(lambda (,whole ,environment) ,@local-decs (block ,block-name ,body)))) `(progn (eval-when (:compile-toplevel) (c::do-compiler-macro-compile-time ',name #',def)) (eval-when (:load-toplevel :execute) (c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))))) (defun c::%define-compiler-macro (name definition lambda-list doc) (assert (eval:interpreted-function-p definition)) (setf (eval:interpreted-function-name definition) (let ((*print-case* :upcase)) (format nil "DEFINE-COMPILER-MACRO ~S" name))) (setf (eval:interpreted-function-arglist definition) lambda-list) (c::%%define-compiler-macro name definition doc)) ;;; (defun c::%%define-compiler-macro (name definition doc) (setf (compiler-macro-function name) definition) (setf (documentation name 'compiler-macro) doc) name) ;;;; DEFINE-SYMBOL-MACRO ;;; define-symbol-macro -- Public ;;; (defmacro define-symbol-macro (name expansion) `(eval-when (:compile-toplevel :load-toplevel :execute) (%define-symbol-macro ',name ',expansion (c::source-location)))) ;;; (defun %define-symbol-macro (name expansion source-location) (unless (symbolp name) (error 'simple-type-error :datum name :expected-type 'symbol :format-control (intl:gettext "Symbol macro name is not a symbol: ~S.") :format-arguments (list name))) (ecase (info variable kind name) ((:macro :global nil) (setf (info variable kind name) :macro) (setf (info variable macro-expansion name) expansion) (set-defvar-source-location name source-location)) (:special (error 'simple-program-error :format-control (intl:gettext "Symbol macro name already declared special: ~S.") :format-arguments (list name))) (:constant (error 'simple-program-error :format-control (intl:gettext "Symbol macro name already declared constant: ~S.") :format-arguments (list name)))) name) ;;; DEFTYPE is a lot like DEFMACRO. (defmacro deftype (name arglist &body body) "Syntax like DEFMACRO, but defines a new type." (unless (symbolp name) (simple-program-error (intl:gettext "~S -- Type name not a symbol.") name)) (and lisp::*enable-package-locked-errors* (symbol-package name) (ext:package-definition-lock (symbol-package name)) (restart-case (error 'lisp::package-locked-error :package (symbol-package name) :format-control (intl:gettext "defining type ~A") :format-arguments (list name)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable package's definition-lock then continue") stream)) (setf (ext:package-definition-lock (symbol-package name)) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Unlock all packages, then continue") stream)) (lisp::unlock-all-packages)))) (let ((whole (gensym "WHOLE-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro arglist whole body name 'deftype :default-default ''*) (when doc (intl::note-translatable intl::*default-domain* doc)) `(eval-when (:compile-toplevel :load-toplevel :execute) (set-defvar-source-location ',name (c::source-location)) (%deftype ',name #'(lambda (,whole) ,@local-decs (block ,name ,body)) ,@(when doc `(,doc))))))) ;;; (defun %deftype (name expander &optional doc) (when (info declaration recognized name) (error (intl:gettext "Deftype already names a declaration: ~S.") name)) (ecase (info type kind name) (:primitive (when *type-system-initialized* (error (intl:gettext "Illegal to redefine standard type: ~S.") name))) (:instance (warn (intl:gettext "Redefining class ~S to be a DEFTYPE.") name) (undefine-structure (layout-info (%class-layout (kernel::find-class name)))) (setf (class-cell-class (find-class-cell name)) nil) (setf (info type compiler-layout name) nil) (setf (info type kind name) :defined)) (:defined) ((nil) (setf (info type kind name) :defined))) (setf (info type expander name) expander) (when doc (setf (documentation name 'type) doc)) ;; ### Bootstrap hack -- we need to define types before %note-type-defined ;; is defined. (when (fboundp 'c::%note-type-defined) (c::%note-type-defined name)) name) ;;; And so is DEFINE-SETF-EXPANDER. (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.") (defmacro define-setf-expander (access-fn lambda-list &body body) "Syntax like DEFMACRO, but creates a Setf-Expansion generator. The body must be a form that returns the five magical values." (unless (symbolp access-fn) (simple-program-error (intl:gettext "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER.") access-fn)) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro lambda-list whole body access-fn 'define-setf-expander :environment environment) (when doc (intl::note-translatable intl::*default-domain* doc)) `(eval-when (:compile-toplevel :load-toplevel :execute) (%define-setf-macro ',access-fn #'(lambda (,whole ,environment) ,@local-decs (block ,access-fn ,body)) nil ',doc))))) (defmacro define-setf-method (&rest stuff) "Obsolete, use define-setf-expander." `(define-setf-expander ,@stuff)) ;;; %DEFINE-SETF-MACRO -- Internal ;;; ;;; Do stuff for defining a setf macro. ;;; (defun %define-setf-macro (name expander inverse doc) (cond ((not (fboundp `(setf ,name)))) ((info function accessor-for name) (warn (intl:gettext "Defining setf macro for destruct slot accessor; redefining as ~ a normal function:~% ~S") name) (c::define-function-name name)) ((not (eq (symbol-package name) (symbol-package 'aref))) (warn (intl:gettext "Defining setf macro for ~S, but ~S is fbound.") name `(setf ,name)))) (when (or inverse (info setf inverse name)) (setf (info setf inverse name) inverse)) (when (or expander (info setf expander name)) (setf (info setf expander name) expander)) (when doc (setf (documentation name 'setf) doc)) name) ;;;; Destructuring-bind (defmacro destructuring-bind (lambda-list arg-list &rest body) "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." (let* ((arg-list-name (gensym "ARG-LIST-"))) (multiple-value-bind (body local-decls) (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind :annonymousp t :doc-string-allowed nil) `(let ((,arg-list-name ,arg-list)) ,@local-decls ,body)))) ;;;; Defun, Defvar, Defparameter, Defconstant: ;;; Defun -- Public ;;; ;;; Very similar to Defmacro, but simpler. We don't have to parse the ;;; lambda-list. ;;; (defmacro defun (&whole source name lambda-list &parse-body (body decls doc)) (multiple-value-bind (valid block-name) (valid-function-name-p name) (declare (ignore valid)) (when doc (intl::note-translatable intl::*default-domain* doc)) (let ((def `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))) `(c::%defun ',name #',def ,doc ',source)))) ;;; %Defun, %%Defun -- Internal ;;; ;;; Similar to %Defmacro, ... ;;; (defun c::%%defun (name def doc &optional inline-expansion) (c::define-function-name name) (setf (fdefinition name) def) (when doc (if (and (consp name) (eq (first name) 'setf)) (setf (documentation (second name) 'setf) doc) (setf (documentation name 'function) doc))) (when (eq (info function where-from name) :assumed) (setf (info function where-from name) :defined) (when (info function assumed-type name) (setf (info function assumed-type name) nil))) (when (or inline-expansion (info function inline-expansion name)) (setf (info function inline-expansion name) inline-expansion)) name) (defun c::%defun (name def doc source) (declare (ignore source)) (assert (eval:interpreted-function-p def)) (setf (eval:interpreted-function-name def) name) (let ((inline-expansion nil)) (when (memq (info function inlinep name) '(:inline :maybe-inline)) (multiple-value-bind (lambda-expression closure-p) (function-lambda-expression def) (unless closure-p (setq inline-expansion lambda-expression)))) (c::%%defun name def doc inline-expansion))) (defun set-defvar-textdomain (name domain) (setf (c::info variable textdomain name) domain)) ;;; DEFCONSTANT -- Public ;;; (defmacro defconstant (var val &optional doc) "For defining global constants at top level. The DEFCONSTANT says that the value is constant and may be compiled into code. If the variable already has a value, and this is not equal to the init, an error is signalled. The third argument is an optional documentation string for the variable." (when doc (intl::note-translatable intl::*default-domain* doc)) `(progn (eval-when (:compile-toplevel) (c::do-defconstant-compile-time ',var ,val ',doc)) (eval-when (:load-toplevel :execute) (set-defvar-textdomain ',var ,intl::*default-domain*) (c::%%defconstant ',var ,val ',doc (c::source-location))))) (defun set-defvar-source-location (name source-location) (setf (info :source-location :defvar name) source-location)) ;;; %Defconstant, %%Defconstant -- Internal ;;; ;;; Like the other %mumbles except that we currently actually do something ;;; interesting at load time, namely checking if the constant is being ;;; redefined. ;;; (defun c::%defconstant (name value doc) (c::%%defconstant name value doc nil)) ;;; (defun c::%%defconstant (name value doc source-location) (when doc (setf (documentation name 'variable) doc)) (when (boundp name) (unless (equalp (symbol-value name) value) (cerror (intl:gettext "Go ahead and change the value.") (intl:gettext "Constant ~S being redefined.") name))) (setf (symbol-value name) value) (setf (info variable kind name) :constant) (clear-info variable constant-value name) (set-defvar-source-location name source-location) name) (defmacro defvar (var &optional (val nil valp) (doc nil docp)) "For defining global variables at top level. Declares the variable SPECIAL and, optionally, initializes it. If the variable already has a value, the old value is not clobbered. The third argument is an optional documentation string for the variable." (when docp (intl::note-translatable intl::*default-domain* doc)) `(progn (declaim (special ,var)) ,@(when valp `((unless (boundp ',var) (setq ,var ,val)))) ,@(when docp `((setf (documentation ',var 'variable) ',doc) (eval-when (:load-toplevel :execute) (set-defvar-textdomain ',var ,intl::*default-domain*)))) (set-defvar-source-location ',var (c::source-location)) ',var)) (defmacro defparameter (var val &optional (doc nil docp)) "Defines a parameter that is not normally changed by the program, but that may be changed without causing an error. Declares the variable special and sets its value to VAL. The third argument is an optional documentation string for the parameter." (when docp (intl::note-translatable intl::*default-domain* doc)) `(progn (declaim (special ,var)) (setq ,var ,val) ,@(when docp `((setf (documentation ',var 'variable) ',doc) (eval-when (:load-toplevel :execute) (set-defvar-textdomain ',var ,intl::*default-domain*)))) (set-defvar-source-location ',var (c::source-location)) ',var)) ;;;; ASSORTED CONTROL STRUCTURES (defmacro when (test &body forms) "First arg is a predicate. If it is non-null, the rest of the forms are evaluated as a PROGN." `(cond (,test nil ,@forms))) (defmacro unless (test &rest forms) "First arg is a predicate. If it is null, the rest of the forms are evaluated as a PROGN." `(cond ((not ,test) nil ,@forms))) (defmacro return (&optional (value nil)) `(return-from nil ,value)) (defmacro prog (varlist &parse-body (body decls)) `(block nil (let ,varlist ,@decls (tagbody ,@body)))) (defmacro prog* (varlist &parse-body (body decls)) `(block nil (let* ,varlist ,@decls (tagbody ,@body)))) ;;; Prog1, Prog2 -- Public ;;; ;;; These just turn into a Let. ;;; (defmacro prog1 (result &rest body) (let ((n-result (gensym))) `(let ((,n-result ,result)) ,@body ,n-result))) ;;; (defmacro prog2 (form1 result &rest body) `(prog1 (progn ,form1 ,result) ,@body)) ;;; And, Or -- Public ;;; ;;; AND and OR are defined in terms of IF. ;;; (defmacro and (&rest forms) (cond ((endp forms) t) ((endp (rest forms)) (first forms)) (t `(if ,(first forms) (and ,@(rest forms)) nil)))) ;;; (defmacro or (&rest forms) (cond ((endp forms) nil) ((endp (rest forms)) (first forms)) (t (let ((n-result (gensym))) `(let ((,n-result ,(first forms))) (if ,n-result ,n-result (or ,@(rest forms)))))))) ;;; Cond -- Public ;;; ;;; COND also turns into IF. ;;; (defmacro cond (&rest clauses) (if (endp clauses) nil (let ((clause (first clauses))) (when (atom clause) (error (intl:gettext "Cond clause should be a non-empty list: ~S.") clause)) (let ((test (first clause)) (forms (rest clause))) (if (endp forms) (let ((n-result (gensym))) `(let ((,n-result ,test)) (if ,n-result ,n-result (cond ,@(rest clauses))))) `(if ,test (progn ,@forms) (cond ,@(rest clauses)))))))) ;;;; Multiple value macros: ;;; Multiple-Value-XXX -- Public ;;; ;;; All the multiple-value receiving forms are defined in terms of ;;; Multiple-Value-Call. ;;; (defmacro multiple-value-setq (varlist value-form) (unless (and (listp varlist) (every #'symbolp varlist)) (simple-program-error (intl:gettext "Varlist is not a list of symbols: ~S.") varlist)) (if varlist `(values (setf (values ,@varlist) ,value-form)) `(values ,value-form))) ;;; (defmacro multiple-value-bind (varlist value-form &body body) (unless (and (listp varlist) (every #'symbolp varlist)) (simple-program-error (intl:gettext "Varlist is not a list of symbols: ~S.") varlist)) (if (= (length varlist) 1) `(let ((,(car varlist) ,value-form)) ,@body) (let ((ignore (gensym))) `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list varlist) &rest ,ignore) (declare (ignore ,ignore)) ,@body) ,value-form)))) ;;; (defmacro multiple-value-list (value-form) `(multiple-value-call #'list ,value-form)) (defmacro nth-value (n form) "Evaluates FORM and returns the Nth value (zero based). This involves no consing when N is a trivial constant integer." (if (integerp n) (let ((dummy-list nil) (keeper (gensym "KEEPER-"))) ;; We build DUMMY-LIST, a list of variables to bind to useless ;; values, then we explicitly IGNORE those bindings and return ;; KEEPER, the only thing we're really interested in right now. (dotimes (i n) (push (gensym "IGNORE-") dummy-list)) `(multiple-value-bind (,@dummy-list ,keeper) ,form (declare (ignore ,@dummy-list)) ,keeper)) (once-only ((n n)) `(case (the (values fixnum &rest t) ,n) (0 (nth-value 0 ,form)) (1 (nth-value 1 ,form)) (2 (nth-value 2 ,form)) (T (nth (the (values fixnum &rest t) ,n) (multiple-value-list ,form))))))) ;;;; SETF and friends. ;;; Note: The expansions for SETF and friends sometimes create needless ;;; LET-bindings of argument values. The compiler will remove most of ;;; these spurious bindings, so SETF doesn't worry too much about creating ;;; them. ;;; The inverse for a generalized-variable reference function is stored in ;;; one of two ways: ;;; ;;; A SETF inverse property corresponds to the short form of DEFSETF. It is ;;; the name of a function takes the same args as the reference form, plus a ;;; new-value arg at the end. ;;; ;;; A SETF method expander is created by the long form of DEFSETF or ;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference ;;; form and that produces five values: a list of temporary variables, a list ;;; of value forms, a list of the single store-value form, a storing function, ;;; and an accessing function. (defun get-setf-expansion (form &optional environment) "Returns five values needed by the SETF machinery: a list of temporary variables, a list of values with which to fill them, a list of temporaries for the new values, the setting function, and the accessing function." (let (temp) (cond ((symbolp form) (multiple-value-bind (expansion expanded) (macroexpand-1 form environment) (if expanded (get-setf-expansion expansion environment) (let ((new-var (gensym))) (values nil nil (list new-var) `(setq ,form ,new-var) form))))) ;; ;; Local functions inhibit global setf methods... ((and environment (let ((name (car form))) (dolist (x (c::lexenv-functions environment) nil) (when (and (eq (nth-value 1 (valid-function-name-p (car x))) name) (not (c::defined-function-p (cdr x)))) (return t))))) (expand-or-get-setf-inverse form environment)) ((setq temp (info setf inverse (car form))) (get-setf-method-inverse form `(,temp) nil)) ((setq temp (info setf expander (car form))) (funcall temp form environment)) (t (expand-or-get-setf-inverse form environment))))) (defun get-setf-method-multiple-value (form &optional env) "Obsolete: use GET-SETF-EXPANSION." (get-setf-expansion form env)) ;;; ;;; If a macro, expand one level and try again. If not, go for the ;;; SETF function. (defun expand-or-get-setf-inverse (form environment) (multiple-value-bind (expansion expanded) (macroexpand-1 form environment) (if expanded (get-setf-expansion expansion environment) (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t)))) (defun get-setf-method-inverse (form inverse setf-function) (let ((new-var (gensym)) (vars nil) (vals nil)) (dolist (x (cdr form)) (push (gensym) vars) (push x vals)) (setq vals (nreverse vals)) (values vars vals (list new-var) (if setf-function `(,@inverse ,new-var ,@vars) `(,@inverse ,@vars ,new-var)) `(,(car form) ,@vars)))) (defun get-setf-method (form &optional environment) "Obsolete: use GET-SETF-EXPANSION and handle multiple store values." (multiple-value-bind (temps value-forms store-vars store-form access-form) (get-setf-expansion form environment) (when (cdr store-vars) (error (intl:gettext "GET-SETF-METHOD used for a form with multiple store ~ variables:~% ~S") form)) (values temps value-forms store-vars store-form access-form))) (defun defsetter (fn rest) (let ((arglist (car rest)) (arglist-var (gensym "ARGS-")) (new-var (car (cadr rest)))) (multiple-value-bind (body local-decs doc) (parse-defmacro arglist arglist-var (cddr rest) fn 'defsetf) (when doc (intl::note-translatable intl::*default-domain* doc)) (values `(lambda (,arglist-var ,new-var) ,@local-decs ,body) doc)))) (defmacro defsetf (access-fn &rest rest) "Associates a SETF update function or macro with the specified access function or macro. The format is complex. See the manual for details." (cond ((not (listp (car rest))) `(eval-when (load compile eval) (%define-setf-macro ',access-fn nil ',(car rest) ,(when (and (car rest) (stringp (cadr rest))) `',(cadr rest))))) ((and (cdr rest) (listp (cadr rest))) (destructuring-bind (lambda-list (&rest store-variables) &body body) rest (let ((arglist-var (gensym "ARGS-")) (access-form-var (gensym "ACCESS-FORM-")) (env-var (gensym "ENVIRONMENT-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro `(,lambda-list ,@store-variables) arglist-var body access-fn 'defsetf :annonymousp t) (when doc (intl::note-translatable intl::*default-domain* doc)) `(eval-when (load compile eval) (%define-setf-macro ',access-fn #'(lambda (,access-form-var ,env-var) (declare (ignore ,env-var)) (%defsetf ,access-form-var ,(length store-variables) #'(lambda (,arglist-var) ,@local-decs (block ,access-fn ,body)))) nil ',doc)))))) (t (error (intl:gettext "Ill-formed DEFSETF for ~S.") access-fn)))) (defun %defsetf (orig-access-form num-store-vars expander) (collect ((subforms) (subform-vars) (subform-exprs) (store-vars)) (dolist (subform (cdr orig-access-form)) (if (constantp subform) (subforms subform) (let ((var (gensym))) (subforms var) (subform-vars var) (subform-exprs subform)))) (dotimes (i num-store-vars) (store-vars (gensym))) (values (subform-vars) (subform-exprs) (store-vars) (funcall expander (cons (subforms) (store-vars))) `(,(car orig-access-form) ,@(subforms))))) ;;; SETF -- Public ;;; ;;; Except for atoms, we always call GET-SETF-METHOD, since it has some ;;; non-trivial semantics. But when there is a setf inverse, and G-S-M uses ;;; it, then we return a call to the inverse, rather than returning a hairy let ;;; form. This is probably important mainly as a convenince in allowing the ;;; use of setf inverses without the full interpreter. ;;; (defmacro setf (&rest args &environment env) "Takes pairs of arguments like SETQ. The first is a place and the second is the value that is supposed to go into that place. Returns the last value. The place argument may be any of the access forms for which SETF knows a corresponding setting form." (let ((nargs (length args))) (cond ((= nargs 2) (let ((place (first args)) (value-form (second args))) (if (atom place) `(setq ,place ,value-form) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion place env) (declare (ignore getter)) (let ((inverse (info setf inverse (car place)))) (if (and inverse (eq inverse (car setter))) `(,inverse ,@(cdr place) ,value-form) `(let* (,@(mapcar #'list dummies vals)) (multiple-value-bind ,newval ,value-form ,setter)))))))) ((oddp nargs) (error (intl:gettext "Odd number of args to SETF."))) (t (do ((a args (cddr a)) (l nil)) ((null a) `(progn ,@(nreverse l))) (setq l (cons (list 'setf (car a) (cadr a)) l))))))) (defmacro psetf (&rest args &environment env) "This is to SETF as PSETQ is to SETQ. Args are alternating place expressions and values to go into those places. All of the subforms and values are determined, left to right, and only then are the locations updated. Returns NIL." (collect ((let*-bindings) (mv-bindings) (setters)) (do ((a args (cddr a))) ((endp a)) (if (endp (cdr a)) (simple-program-error (intl:gettext "Odd number of args to PSETF."))) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion (car a) env) (declare (ignore getter)) (let*-bindings (mapcar #'list dummies vals)) (mv-bindings (list newval (cadr a))) (setters setter))) (labels ((thunk (let*-bindings mv-bindings) (if let*-bindings `(let* ,(car let*-bindings) (multiple-value-bind ,@(car mv-bindings) ,(thunk (cdr let*-bindings) (cdr mv-bindings)))) `(progn ,@(setters) nil)))) (thunk (let*-bindings) (mv-bindings))))) (defmacro shiftf (&rest args &environment env) "One or more SETF-style place expressions, followed by a single value expression. Evaluates all of the expressions in turn, then assigns the value of each expression to the place on its left, returning the value of the leftmost." (when args (collect ((let*-bindings) (mv-bindings) (setters) (getters)) ;; The last arg isn't necessarily a place, so we have to handle ;; that separately. (dolist (arg (butlast args)) (multiple-value-bind (temps subforms store-vars setter getter) (get-setf-expansion arg env) (loop for temp in temps for subform in subforms do (let*-bindings `(,temp ,subform))) (mv-bindings store-vars) (setters setter) (getters getter))) ;; Handle the last arg specially here. Just put something to ;; force the setter so the setter for the previous var gets set, ;; and the getter is just the last arg itself. (setters nil) (getters (car (last args))) (labels ((thunk (mv-bindings getters) (if mv-bindings `((multiple-value-bind ,(car mv-bindings) ,(car getters) ,@(thunk (cdr mv-bindings) (cdr getters)))) `(,@(butlast (setters)))))) `(let* ,(let*-bindings) (multiple-value-bind ,(car (mv-bindings)) ,(car (getters)) ,@(thunk (mv-bindings) (cdr (getters))) (values ,@(car (mv-bindings))))))))) (defmacro rotatef (&rest args &environment env) "Takes any number of SETF-style place expressions. Evaluates all of the expressions in turn, then assigns to each place the value of the form to its right. The rightmost form gets the value of the leftmost. Returns NIL." (when args (collect ((let*-bindings) (mv-bindings) (setters) (getters)) (dolist (arg args) (multiple-value-bind (temps subforms store-vars setter getter) (get-setf-expansion arg env) (loop for temp in temps for subform in subforms do (let*-bindings `(,temp ,subform))) (mv-bindings store-vars) (setters setter) (getters getter))) (setters nil) (getters (car (getters))) (labels ((thunk (mv-bindings getters) (if mv-bindings `((multiple-value-bind ,(car mv-bindings) ,(car getters) ,@(thunk (cdr mv-bindings) (cdr getters)))) (setters)))) `(let* ,(let*-bindings) ,@(thunk (mv-bindings) (cdr (getters)))))))) (defmacro define-modify-macro (name lambda-list function &optional doc-string) "Creates a new read-modify-write macro like PUSH or INCF." (let ((other-args nil) (rest-arg nil) (env (gensym "ENV-")) (reference (gensym "PLACE-"))) ;; Parse out the variable names and rest arg from the lambda list. (do ((ll lambda-list (cdr ll)) (arg nil)) ((null ll)) (setq arg (car ll)) (cond ((eq arg '&optional)) ((eq arg '&rest) (if (symbolp (cadr ll)) (setq rest-arg (cadr ll)) (error (intl:gettext "Non-symbol &rest arg in definition of ~S.") name)) (if (null (cddr ll)) (return nil) (error (intl:gettext "Illegal stuff after &rest arg in Define-Modify-Macro.")))) ((memq arg '(&key &allow-other-keys &aux)) (error (intl:gettext "~S not allowed in Define-Modify-Macro lambda list.") arg)) ((symbolp arg) (push arg other-args)) ((and (listp arg) (symbolp (car arg))) (push (car arg) other-args)) (t (error (intl:gettext "Illegal stuff in lambda list of Define-Modify-Macro."))))) (setq other-args (nreverse other-args)) `(defmacro ,name (,reference ,@lambda-list &environment ,env) ,doc-string (multiple-value-bind (dummies vals newval setter getter) (get-setf-method ,reference ,env) (do ((d dummies (cdr d)) (v vals (cdr v)) (let-list nil (cons (list (car d) (car v)) let-list))) ((null d) (push (list (car newval) ,(if rest-arg `(list* ',function getter ,@other-args ,rest-arg) `(list ',function getter ,@other-args))) let-list) `(let* ,(nreverse let-list) ,setter))))))) (defmacro push (obj place &environment env) "Takes an object and a location holding a list. Conses the object onto the list, returning the modified list. OBJ is evaluated before PLACE." ;; This special case for place being a symbol isn't strictly needed. ;; It's so we can do push (and pushnew) with a kernel.core. (if (and (symbolp place) (eq place (macroexpand place env))) `(setq ,place (cons ,obj ,place)) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion place env) (cond ((cdr newval) ;; Handle multiple values (let ((g (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (rest obj)))) `(multiple-value-bind ,g ,obj (let* (,@(mapcar #'list dummies vals)) (multiple-value-bind ,newval (values ,@(mapcar #'(lambda (a b) (list 'cons a b)) g (rest getter))) ,setter))))) (t ;; A single value (let ((g (gensym))) `(let* ((,g ,obj) ,@(mapcar #'list dummies vals) (,@newval (cons ,g ,getter))) ,setter))))))) (defmacro pushnew (obj place &rest keys &environment env) "Takes an object and a location holding a list. If the object is already in the list, does nothing. Else, conses the object onto the list. Returns NIL. If there is a :TEST keyword, this is used for the comparison." (if (and (symbolp place) (eq place (macroexpand place env))) `(setq ,place (adjoin ,obj ,place ,@keys)) (multiple-value-bind (vars vals stores setter getter) (get-setf-expansion place env) (cond ((cdr stores) ;; Multiple values (let ((g (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (rest obj)))) `(multiple-value-bind ,g ,obj (let* (,@(mapcar #'list vars vals)) (multiple-value-bind ,stores (values ,@(mapcar #'(lambda (a b) `(adjoin ,a ,b ,@keys)) g (rest getter))) ,setter))))) (t ;; Single value (let ((g (gensym))) `(let* ((,g ,obj) ,@(mapcar #'list vars vals) (,@stores (adjoin ,g ,getter ,@keys))) ,setter))))))) (defmacro pop (place &environment env) "The argument is a location holding a list. Pops one item off the front of the list and returns it." (if (and (symbolp place) (eq place (macroexpand place env))) `(prog1 (car ,place) (setq ,place (cdr ,place))) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (do* ((d dummies (cdr d)) (v vals (cdr v)) (let-list nil)) ((null d) (push (list (car newval) getter) let-list) `(let* ,(nreverse let-list) (prog1 (car ,(car newval)) (setq ,(car newval) (cdr ,(car newval))) ,setter))) (push (list (car d) (car v)) let-list))))) ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3 (defmacro incf (place &optional (delta 1) &environment env) "The first argument is some location holding a number. This number is incremented by the second argument, DELTA, which defaults to 1." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((d (gensym))) `(let* (,@(mapcar #'list dummies vals) (,d ,delta) (,(car newval) (+ ,getter ,d))) ,setter)))) (defmacro decf (place &optional (delta 1) &environment env) "The first argument is some location holding a number. This number is decremented by the second argument, DELTA, which defaults to 1." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((d (gensym))) `(let* (,@(mapcar #'list dummies vals) (,d ,delta) (,(car newval) (- ,getter ,d))) ,setter)))) (defmacro remf (place indicator &environment env) "Place may be any place expression acceptable to SETF, and is expected to hold a property list or (). This list is destructively altered to remove the property specified by the indicator. Returns T if such a property was present, NIL if not." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (do* ((d dummies (cdr d)) (v vals (cdr v)) (let-list nil) (ind-temp (gensym)) (local1 (gensym)) (local2 (gensym))) ((null d) ;; See ANSI 5.1.3 for why we do out-of-order evaluation (push (list ind-temp indicator) let-list) (push (list (car newval) getter) let-list) `(let* ,(nreverse let-list) (do ((,local1 ,(car newval) (cddr ,local1)) (,local2 nil ,local1)) ((atom ,local1) nil) (cond ((atom (cdr ,local1)) (error (intl:gettext "Odd-length property list in REMF."))) ((eq (car ,local1) ,ind-temp) (cond (,local2 (rplacd (cdr ,local2) (cddr ,local1)) (return t)) (t (setq ,(car newval) (cddr ,(car newval))) ,setter (return t)))))))) (push (list (car d) (car v)) let-list)))) ;;; The built-in DEFSETFs. (defsetf car %rplaca) (defsetf cdr %rplacd) (defsetf caar (x) (v) `(%rplaca (car ,x) ,v)) (defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v)) (defsetf cdar (x) (v) `(%rplacd (car ,x) ,v)) (defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v)) (defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v)) (defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v)) (defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v)) (defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v)) (defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v)) (defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v)) (defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v)) (defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v)) (defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v)) (defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v)) (defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v)) (defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v)) (defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v)) (defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v)) (defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v)) (defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v)) (defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v)) (defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v)) (defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v)) (defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v)) (defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v)) (defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v)) (defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v)) (defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v)) (defsetf first %rplaca) (defsetf second (x) (v) `(%rplaca (cdr ,x) ,v)) (defsetf third (x) (v) `(%rplaca (cddr ,x) ,v)) (defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v)) (defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v)) (defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v)) (defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v)) (defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v)) (defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v)) (defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v)) (defsetf rest %rplacd) (defsetf elt %setelt) (defsetf aref %aset) (defsetf row-major-aref %set-row-major-aref) (defsetf svref %svset) (defsetf char %charset) (defsetf bit %bitset) (defsetf schar %scharset) (defsetf sbit %sbitset) (defsetf %array-dimension %set-array-dimension) (defsetf %raw-bits %set-raw-bits) (defsetf symbol-value set) (defsetf symbol-function fset) (defsetf symbol-plist %set-symbol-plist) (defsetf nth %setnth) (defsetf fill-pointer %set-fill-pointer) (defsetf search-list %set-search-list) (defsetf sap-ref-8 %set-sap-ref-8) (defsetf signed-sap-ref-8 %set-signed-sap-ref-8) (defsetf sap-ref-16 %set-sap-ref-16) (defsetf signed-sap-ref-16 %set-signed-sap-ref-16) (defsetf sap-ref-32 %set-sap-ref-32) (defsetf signed-sap-ref-32 %set-signed-sap-ref-32) (defsetf sap-ref-64 %set-sap-ref-64) (defsetf signed-sap-ref-64 %set-signed-sap-ref-64) (defsetf sap-ref-sap %set-sap-ref-sap) (defsetf sap-ref-single %set-sap-ref-single) (defsetf sap-ref-double %set-sap-ref-double) #+(or x86 long-float) (defsetf sap-ref-long %set-sap-ref-long) (define-setf-expander getf (place prop &optional default &environment env) (multiple-value-bind (temps values stores set get) (get-setf-method place env) (let ((newval (gensym)) (ptemp (gensym)) (def-temp (if default (gensym)))) (values `(,@temps ,ptemp ,@(if default `(,def-temp))) `(,@values ,prop ,@(if default `(,default))) `(,newval) `(let ((,(car stores) (%putf ,get ,ptemp ,newval))) ,set ,newval) `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) (define-setf-expander get (symbol prop &optional default) (let ((symbol-temp (gensym)) (prop-temp (gensym)) (def-temp (gensym)) (newval (gensym))) (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp))) `(,symbol ,prop ,@(if default `(,default))) (list newval) `(%put ,symbol-temp ,prop-temp ,newval) `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) (define-setf-expander gethash (key hashtable &optional default) (let ((key-temp (gensym)) (hashtable-temp (gensym)) (default-temp (gensym)) (new-value-temp (gensym))) (values `(,key-temp ,hashtable-temp ,@(if default `(,default-temp))) `(,key ,hashtable ,@(if default `(,default))) `(,new-value-temp) `(%puthash ,key-temp ,hashtable-temp ,new-value-temp) `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp)))))) (defsetf subseq (sequence start &optional (end nil)) (v) `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v)) ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as ;;; it used to be.) The function arg must be constant, and is converted to an ;;; APPLY of ther SETF function, which ought to exist. ;;; (define-setf-expander apply (function &rest args) (unless (and (listp function) (= (list-length function) 2) (eq (first function) 'function) (symbolp (second function))) (error (intl:gettext "Setf of Apply is only defined for function args like #'symbol."))) (let ((function (second function)) (new-var (gensym)) (vars nil)) (dolist (x args) (declare (ignore x)) (push (gensym) vars)) (values vars args (list new-var) `(apply #'(setf ,function) ,new-var ,@vars) `(apply #',function ,@vars)))) ;;; Special-case a BYTE bytespec so that the compiler can recognize it. ;;; (define-setf-expander ldb (bytespec place &environment env) "The first argument is a byte specifier. The second is any place form acceptable to SETF. Replaces the specified byte of the number in this place with bits from the low-order end of the new value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (if (and (consp bytespec) (eq (car bytespec) 'byte)) (let ((n-size (gensym)) (n-pos (gensym)) (n-new (gensym))) (values (list* n-size n-pos dummies) (list* (second bytespec) (third bytespec) vals) (list n-new) `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) ,getter))) ,setter ,n-new) `(ldb (byte ,n-size ,n-pos) ,getter))) (let ((btemp (gensym)) (gnuval (gensym))) (values (cons btemp dummies) (cons bytespec vals) (list gnuval) `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) ,setter ,gnuval) `(ldb ,btemp ,getter)))))) (define-setf-expander mask-field (bytespec place &environment env) "The first argument is a byte specifier. The second is any place form acceptable to SETF. Replaces the specified byte of the number in this place with bits from the corresponding position in the new value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((btemp (gensym)) (gnuval (gensym))) (values (cons btemp dummies) (cons bytespec vals) (list gnuval) `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) ,setter ,gnuval) `(mask-field ,btemp ,getter))))) (define-setf-expander the (type place &environment env) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (values dummies vals newval (subst `(the ,type ,(car newval)) (car newval) setter) `(the ,type ,getter)))) (define-setf-expander values (&rest places &environment env) (collect ((setters) (getters)) (let ((all-dummies '()) (all-vals '()) (newvals '())) (dolist (place places) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion place env) ;; ANSI CL 5.1.2.3 explains that extra places are set to ;; nil. (setf all-dummies (append all-dummies dummies (cdr newval))) (setf all-vals (append all-vals vals (mapcar (constantly nil) (cdr newval)))) (setf newvals (append newvals (list (car newval)))) (setters setter) (getters getter))) (values all-dummies all-vals newvals `(values ,@(setters)) `(values ,@(getters)))))) ;;;; CASE, TYPECASE, & Friends. (eval-when (:compile-toplevel :load-toplevel :execute) ;;; CASE-BODY returns code for all the standard "case" macros. Name is the ;;; macro name, and keyform is the thing to case on. Multi-p indicates whether ;;; a branch may fire off a list of keys; otherwise, a key that is a list is ;;; interpreted in some way as a single key. When multi-p, test is applied to ;;; the value of keyform and each key for a given branch; otherwise, test is ;;; applied to the value of keyform and the entire first element, instead of ;;; each part, of the case branch. When errorp, no t or otherwise branch is ;;; permitted, and an ERROR form is generated. When proceedp, it is an error ;;; to omit errorp, and the ERROR form generated is executed within a ;;; RESTART-CASE allowing keyform to be set and retested. ;;; ;;; If ALLOW-OTHERWISE, then we allow T and OTHERWISE clauses and also ;;; generate an ERROR form. (This is for CCASE and ECASE which allow ;;; using T and OTHERWISE as regular keys.) ;;; (defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise) (let ((keyform-value (gensym)) (clauses ()) (keys ())) (do* ((case-list cases (cdr case-list)) (case (first case-list) (first case-list))) ((null case-list)) (cond ((atom case) (error (intl:gettext "~S -- Bad clause in ~S.") case name)) ((and (not allow-otherwise) (memq (car case) '(t otherwise))) (cond ((null (cdr case-list)) ;; The CLHS says OTHERWISE clause is an OTHERWISE clause ;; only if it's the last case. Otherwise, it's just a ;; normal clause. (push `(t nil ,@(rest case)) clauses)) ((and (eq name 'case)) (let ((key (first case))) (error 'kernel:invalid-case :name name :format-control (intl:gettext "~<~A is a key designator only in the final otherwise-clause. ~ Use (~A) to use it as a normal-clause or move the clause to the ~ correct position.~:@>") :format-arguments (list (list key key)) :references (list '(:ansi-cl :section (5 3)) (list :ansi-cl :macro name))))) ((eq (first case) t) ;; The key T is normal clause, because it's not ;; the last clause. (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) ((and multi-p (listp (first case))) (setf keys (append (first case) keys)) (push `((or ,@(mapcar #'(lambda (key) `(,test ,keyform-value ',key)) (first case))) nil ,@(rest case)) clauses)) (t (when (and allow-otherwise (memq (car case) '(t otherwise))) (warn 'kernel:simple-style-warning :format-control (intl:gettext "Bad style to use ~S in ~S") :format-arguments (list (car case) name))) (push (first case) keys) (push `((,test ,keyform-value ',(first case)) nil ,@(rest case)) clauses)))) (case-body-aux name keyform keyform-value clauses keys proceedp allow-otherwise `(,(if multi-p 'member 'or) ,@keys)))) ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the ;;; cases. Note: it is not necessary that the resulting code signal ;;; case-failure conditions, but that's what KMP's prototype code did. We call ;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has ;;; forms with closures that the compiler causes to be generated at the top of ;;; any function using the case macros, regardless of whether they are needed. ;;; (defun case-body-aux (name keyform keyform-value clauses keys proceedp allow-otherwise expected-type) (if proceedp (let ((block (gensym)) (again (gensym))) `(let ((,keyform-value ,keyform)) (block ,block (tagbody ,again (return-from ,block (cond ,@(nreverse clauses) (t (setf ,keyform-value (setf ,keyform (case-body-error ',name ',keyform ,keyform-value ',expected-type ',keys))) (go ,again)))))))) `(let ((,keyform-value ,keyform)) ,keyform-value ; prevent warnings when key not used eg (case key (t)) (cond ,@(nreverse clauses) ,@(if allow-otherwise `((t (error 'conditions::case-failure :name ',name :datum ,keyform-value :expected-type ',expected-type :possibilities ',keys)))))))) ); eval-when (defun case-body-error (name keyform keyform-value expected-type keys) (restart-case (error 'conditions::case-failure :name name :datum keyform-value :expected-type expected-type :possibilities keys) (store-value (value) :report (lambda (stream) (format stream (intl:gettext "Supply a new value for ~S.") keyform)) :interactive read-evaluated-form value))) (defmacro case (keyform &body cases) "CASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If a singleton key is T or Otherwise then the clause is a default clause." (case-body 'case keyform cases t 'eql nil)) (defmacro ccase (keyform &body cases) "CCASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then a correctable error is signalled." (case-body 'ccase keyform cases t 'eql t t)) (defmacro ecase (keyform &body cases) "ECASE Keyform {({(Key*) | Key} Form*)}* Evaluates the Forms in the first clause with a Key EQL to the value of Keyform. If none of the keys matches then an error is signalled." (case-body 'ecase keyform cases t 'eql nil t)) (defmacro typecase (keyform &body cases) "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If a singleton key is T or Otherwise then the clause is a default clause." (case-body 'typecase keyform cases nil 'typep nil)) (defmacro ctypecase (keyform &body cases) "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." (case-body 'ctypecase keyform cases nil 'typep t t)) (defmacro etypecase (keyform &body cases) "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." (case-body 'etypecase keyform cases nil 'typep nil t)) ;;;; ASSERT and CHECK-TYPE. ;;; ASSERT is written this way, to call ASSERT-ERROR, because of how closures ;;; are compiled. RESTART-CASE has forms with closures that the compiler ;;; causes to be generated at the top of any function using ASSERT, regardless ;;; of whether they are needed. ;;; (defmacro assert (test-form &optional places datum &rest arguments) "Signals an error if the value of test-form is nil. Continuing from this error using the CONTINUE restart will allow the user to alter the value of some locations known to SETF, starting over with test-form. Returns nil." `(loop (when ,test-form (return nil)) (assert-error ',test-form ',places ,datum ,@arguments) ,@(mapcar #'(lambda (place) `(setf ,place (assert-prompt ',place ,place))) places))) (defun assert-error (assertion places datum &rest arguments) (let ((cond (if datum (conditions::coerce-to-condition datum arguments 'simple-error 'error) (make-condition 'simple-error :format-control (intl:gettext "The assertion ~S failed.") :format-arguments (list assertion))))) (restart-case (error cond) (continue () :report (lambda (stream) (assert-report places stream)) nil)))) (defun assert-report (names stream) (format stream (intl:gettext "Retry assertion")) (if names (format stream (intl:ngettext " with new value for ~{~S~^, ~}." " with new values for ~{~S~^, ~}." (length names)) names) (format stream "."))) (defun assert-prompt (name value) (cond ((y-or-n-p (intl:gettext "The old value of ~S is ~S.~ ~%Do you want to supply a new value? ") name value) (format *query-io* (intl:gettext "~&Type a form to be evaluated:~%")) (flet ((read-it () (eval (read *query-io*)))) (if (symbolp name) ;help user debug lexical variables (progv (list name) (list value) (read-it)) (read-it)))) (t value))) ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because of how ;;; closures are compiled. RESTART-CASE has forms with closures that the ;;; compiler causes to be generated at the top of any function using ;;; CHECK-TYPE, regardless of whether they are needed. Because it would be ;;; nice if this were cheap to use, and some things can't afford this excessive ;;; consing (e.g., READ-CHAR), we bend backwards a little. ;;; (defmacro check-type (place type &optional type-string) "Signals an error of type type-error if the contents of place are not of the specified type. If an error is signaled, this can only return if STORE-VALUE is invoked. It will store into place and start over." (let ((place-value (gensym))) `(loop (let ((,place-value ,place)) (when (typep ,place-value ',type) (return nil)) (setf ,place (check-type-error ',place ,place-value ',type ,type-string)))))) (defun check-type-error (place place-value type type-string) (let ((cond (if type-string (make-condition 'simple-type-error :datum place-value :expected-type type :format-control (intl:gettext "The value of ~S is ~S, which is not ~A.") :format-arguments (list place place-value type-string)) (make-condition 'simple-type-error :datum place-value :expected-type type :format-control (intl:gettext "The value of ~S is ~S, which is not of type ~S.") :format-arguments (list place place-value type))))) (restart-case (error cond) (store-value (value) :report (lambda (stream) (format stream (intl:gettext "Supply a new value of ~S.") place)) :interactive read-evaluated-form value)))) ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros ;;; and by CHECK-TYPE. ;;; (defun read-evaluated-form () (format *query-io* (intl:gettext "~&Type a form to be evaluated:~%")) (list (eval (read *query-io*)))) ;;;; With-XXX (defmacro with-open-file ((var filespec &rest open-args) &parse-body (forms decls)) "The file whose name is Filespec is opened using the Open-args and bound to the variable Var. If the call to open is unsuccessful, the forms are not evaluated. The Forms are executed, and when they terminate, normally or otherwise, the file is closed." (let ((abortp (gensym))) `(let ((,var (open ,filespec ,@open-args)) (,abortp t)) ,@decls (unwind-protect (multiple-value-prog1 (progn ,@forms) (setq ,abortp nil)) (when ,var (close ,var :abort ,abortp)))))) (defmacro with-open-stream ((var stream) &parse-body (forms decls)) "The form stream should evaluate to a stream. VAR is bound to the stream and the forms are evaluated as an implicit progn. The stream is closed upon exit." (let ((abortp (gensym))) `(let ((,var ,stream) (,abortp t)) ,@decls (unwind-protect (multiple-value-prog1 (progn ,@forms) (setq ,abortp nil)) (when ,var (close ,var :abort ,abortp)))))) (defmacro with-input-from-string ((var string &key index start end) &parse-body (forms decls)) "Binds the Var to an input stream that returns characters from String and executes the body. See manual for details." ;; The once-only inhibits compiler note for unreachable code when 'end' is true. (once-only ((string string)) `(let ((,var ,(cond ((null end) `(make-string-input-stream ,string ,(or start 0))) ((symbolp end) `(if ,end (make-string-input-stream ,string ,(or start 0) ,end) (make-string-input-stream ,string ,(or start 0)))) (t `(make-string-input-stream ,string ,(or start 0) ,end))))) ,@decls (unwind-protect (multiple-value-prog1 (progn ,@forms) ,@(when index `((setf ,index (string-input-stream-current ,var))))) (close ,var))))) (defmacro with-output-to-string ((var &optional string &key element-type) &parse-body (forms decls)) "If STRING is specified, it must be a string with a fill pointer; the output is incrementally appended to the string (as if by use of VECTOR-PUSH-EXTEND)." (declare (ignore element-type)) (if string `(let ((,var (make-fill-pointer-output-stream ,string))) ,@decls (unwind-protect (progn ,@forms) (close ,var))) `(let ((,var (make-string-output-stream))) ,@decls (unwind-protect (progn ,@forms) (close ,var)) (get-output-stream-string ,var)))) ;;;; Iteration macros: ;; Helper for dotimes. Extract any declarations for the dotimes ;; counter and create a similar declaration for our dummy loop ;; counter. Skip over special declarations, though, because we don't ;; want to make the dummy counter special. ;; ;; Returns two values: ;; 1. Set of declarations for the dotimes loop counter that would be ;; suitable for use in the result-form of the loop, ;; 2. Declarations suitable for the dummy loop counter. (defun dotimes-extract-var-decls (var counter count decls) (let (var-decls counter-decls) (dolist (decl decls) (dolist (d (cdr decl)) (when (member var (cdr d)) (cond ((eq (car d) 'type) (push `(type ,(second d) ,var) var-decls) (push `(type ,(second d) ,counter) counter-decls)) ((eq (car d) 'special) ;; Declare var special, but not the counter (push `(,(car d) ,var) var-decls)) (t (push `(,(car d) ,var) var-decls) (push `(,(car d) ,counter) counter-decls)))))) (unless counter-decls (setf counter-decls (if (numberp count) `((type (integer 0 ,count) ,counter)) `((type unsigned-byte ,counter))))) (values (if var-decls `((declare ,@(nreverse var-decls))) nil) `((declare ,@(nreverse counter-decls)))))) ;;; Make sure we iterate the given number of times, independent of ;;; what the body might do to the index variable. We do this by ;;; repeatedly binding the var in the body and also in the result ;;; form. We also spuriously reference the var in case the body or ;;; result form don't reference the var either. (Mostly modeled on ;;; the dolist macro below.) (defmacro dotimes ((var count &optional (result nil)) &body body) (let ((count-var (gensym "CTR-"))) (multiple-value-bind (forms decls) (parse-body body nil nil) (multiple-value-bind (var-decls ctr-decls) (dotimes-extract-var-decls var count-var count decls) (cond ((numberp count) `(do ((,count-var 0 (1+ ,count-var))) ((>= ,count-var ,count) (let ((,var ,count-var)) ,@var-decls ,var ,result)) ,@ctr-decls (let ((,var ,count-var)) ,@decls ,var (tagbody ,@forms)))) (t (let ((v1 (gensym))) `(do ((,count-var 0 (1+ ,count-var)) (,v1 ,count)) ((>= ,count-var ,v1) (let ((,var ,count-var)) ,@var-decls ,var ,result)) ,@ctr-decls (let ((,var ,count-var)) ,@decls ,var (tagbody ,@forms)))))))))) ;;; We repeatedly bind the var instead of setting it so that we never give the ;;; var a random value such as NIL (which might conflict with a declaration). ;;; If there is a result form, we introduce a gratitous binding of the variable ;;; to NIL w/o the declarations, then evaluate the result form in that ;;; environment. We spuriously reference the gratuitous variable, since we ;;; don't want to use IGNORABLE on what might be a special var. ;;; (defmacro dolist ((var list &optional (result nil)) &body body) (multiple-value-bind (forms decls) (parse-body body nil nil) (let ((n-list (gensym))) `(do* ((,n-list ,list (cdr ,n-list))) ((endp ,n-list) ,@(if (constantp result) `(,result) `((let ((,var nil)) ,@decls ,var ,result)))) (let ((,var (car ,n-list))) ,@decls (tagbody ,@forms)))))) (defmacro do (varlist endlist &parse-body (body decls)) "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Iteration construct. Each Var is initialized in parallel to the value of the specified Init form. On subsequent iterations, the Vars are assigned the value of the Step form (if any) in paralell. The Test is evaluated before each evaluation of the body Forms. When the Test is true, the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an laternate exit mechanism." (do-do-body varlist endlist body decls 'let 'psetq 'do nil)) (defmacro do* (varlist endlist &parse-body (body decls)) "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* Iteration construct. Each Var is initialized sequentially (like LET*) to the value of the specified Init form. On subsequent iterations, the Vars are sequentially assigned the value of the Step form (if any). The Test is evaluated before each evaluation of the body Forms. When the Test is true, the Exit-Forms are evaluated as a PROGN, with the result being the value of the DO. A block named NIL is established around the entire expansion, allowing RETURN to be used as an laternate exit mechanism." (do-do-body varlist endlist body decls 'let* 'setq 'do* nil)) ;;;; Miscellaneous macros: (defmacro psetq (&rest pairs) "PSETQ {var value}* Set the variables to the values, like SETQ, except that assignments happen in parallel, i.e. no assignments take place until all the forms have been evaluated." ;; Given the possibility of symbol-macros, we delegate to PSETF ;; which knows how to deal with them, after checking that syntax is ;; compatible with PSETQ. (do ((pair pairs (cddr pair))) ((endp pair) `(psetf ,@pairs)) (unless (symbolp (car pair)) (error 'simple-program-error :format-control (intl:gettext "variable ~S in PSETQ is not a SYMBOL") :format-arguments (list (car pair)))))) ;;; LAMBDA -- from the ANSI spec. ;;; (defmacro lambda (&whole form &rest bvl-decls-and-body) (declare (ignore bvl-decls-and-body)) `#',form) ;;;; With-Compilation-Unit: ;;; True if we are within a WITH-COMPILATION-UNIT form, which normally causes ;;; nested uses to be NOOPS. ;;; (defvar *in-compilation-unit* nil) ;;; Count of the number of compilation units dynamically enclosed by the ;;; current active WITH-COMPILATION-UNIT that were unwound out of. ;;; (defvar *aborted-compilation-units*) (declaim (special c::*context-declarations*)) ;;; EVALUATE-DECLARATION-CONTEXT -- Internal ;;; ;;; Recursively descend the context form, returning true if this subpart ;;; matches the specified context. ;;; (defun evaluate-declaration-context (context name parent) (multiple-value-bind (valid base) (valid-function-name-p name) (let ((package (and valid (symbolp base) (symbol-package base)))) (if (atom context) (multiple-value-bind (ignore how) (if package (find-symbol (symbol-name base) package) (values nil nil)) (declare (ignore ignore)) (case context (:internal (eq how :internal)) (:external (eq how :external)) (:uninterned (and (symbolp base) (not package))) (:anonymous (not name)) (:macro (eq parent 'defmacro)) (:function (member parent '(defun labels flet function))) (:global (member parent '(defun defmacro function))) (:local (member parent '(labels flet))) (t (error (intl:gettext "Unknown declaration context: ~S.") context)))) (case (first context) (:or (loop for x in (rest context) thereis (evaluate-declaration-context x name parent))) (:and (loop for x in (rest context) always (evaluate-declaration-context x name parent))) (:not (evaluate-declaration-context (second context) name parent)) (:member (member name (rest context) :test #'equal)) (:match (let ((name (concatenate 'string "$" (string base) "$"))) (loop for x in (rest context) thereis (search (string x) name)))) (:package (and package (loop for x in (rest context) thereis (eq (find-package (string x)) package)))) (t (error (intl:gettext "Unknown declaration context: ~S.") context))))))) ;;; PROCESS-CONTEXT-DECLARATIONS -- Internal ;;; ;;; Given a list of context declaration specs, return a new value for ;;; C::*CONTEXT-DECLARATIONS*. ;;; (defun process-context-declarations (decls) (append (mapcar #'(lambda (decl) (unless (>= (length decl) 2) (error (intl:gettext "Context declaration spec should have context and at ~ least one DECLARE form:~% ~S") decl)) #'(lambda (name parent) (when (evaluate-declaration-context (first decl) name parent) (rest decl)))) decls) c::*context-declarations*)) ;;; With-Compilation-Unit -- Public ;;; (defmacro with-compilation-unit (options &body body) "WITH-COMPILATION-UNIT ({Key Value}*) Form* This form affects compilations that take place within its dynamic extent. It is intended to be wrapped around the compilation of all files in the same system. These keywords are defined: :OVERRIDE Boolean-Form One of the effects of this form is to delay undefined warnings until the end of the form, instead of giving them at the end of each compilation. If OVERRIDE is NIL (the default), then the outermost WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying OVERRIDE true causes that form to grab any enclosed warnings, even if it is enclosed by another WITH-COMPILATION-UNIT. :OPTIMIZE Decl-Form Decl-Form should evaluate to an OPTIMIZE declaration specifier. This declaration changes the `global' policy for compilations within the body. :OPTIMIZE-INTERFACE Decl-Form Like OPTIMIZE, except that it specifies the value of the CMU extension OPTIMIZE-INTERFACE policy (which controls argument type and syntax checking.) :CONTEXT-DECLARATIONS List-of-Context-Decls-Form This is a CMU extension which allows compilation to be controlled by pattern matching on the context in which a definition appears. The argument should evaluate to a list of lists of the form: (Context-Spec Declare-Form+) In the indicated context, the specified declare forms are inserted at the head of each definition. The declare forms for all contexts that match are appended together, with earlier declarations getting predecence over later ones. A simple example: :context-declarations '((:external (declare (optimize (safety 2))))) This will cause all functions that are named by external symbols to be compiled with SAFETY 2. The full syntax of context specs is: :INTERNAL, :EXTERNAL True if the symbols is internal (external) in its home package. :UNINTERNED True if the symbol has no home package. :ANONYMOUS True if the function doesn't have any interesting name (not DEFMACRO, DEFUN, LABELS or FLET). :MACRO, :FUNCTION :MACRO is a global (DEFMACRO) macro. :FUNCTION is anything else. :LOCAL, :GLOBAL :LOCAL is a LABELS or FLET. :GLOBAL is anything else. (:OR Context-Spec*) True in any specified context. (:AND Context-Spec*) True only when all specs are true. (:NOT Context-Spec) True when the spec is false. (:MEMBER Name*) True when the name is one of these names (EQUAL test.) (:MATCH Pattern*) True when any of the patterns is a substring of the name. The name is wrapped with $'s, so $FOO matches names beginning with FOO, etc." (let ((override nil) (optimize nil) (optimize-interface nil) (context-declarations nil) (n-fun (gensym)) (n-abort-p (gensym))) (when (oddp (length options)) (error (intl:gettext "Odd number of key/value pairs: ~S.") options)) (do ((opt options (cddr opt))) ((null opt)) (case (first opt) (:override (setq override (second opt))) (:optimize (setq optimize (second opt))) (:optimize-interface (setq optimize-interface (second opt))) (:context-declarations (setq context-declarations (second opt))) (t (warn (intl:gettext "Ignoring unknown option: ~S.") (first opt))))) `(flet ((,n-fun () (let (,@(when optimize `((c::*default-cookie* (c::process-optimize-declaration ,optimize c::*default-cookie*)))) ,@(when optimize-interface `((c::*default-interface-cookie* (c::process-optimize-declaration ,optimize-interface c::*default-interface-cookie*)))) ,@(when context-declarations `((c::*context-declarations* (process-context-declarations ,context-declarations))))) ,@body))) (if (or ,override (not *in-compilation-unit*)) (let ((c::*undefined-warnings* nil) (c::*compiler-error-count* 0) (c::*compiler-warning-count* 0) (c::*compiler-note-count* 0) (*in-compilation-unit* t) (*aborted-compilation-units* 0) (,n-abort-p t)) (handler-bind ((c::parse-unknown-type #'(lambda (c) (c::note-undefined-reference (kernel:parse-unknown-type-specifier c) :type)))) (unwind-protect (multiple-value-prog1 (,n-fun) (setq ,n-abort-p nil)) (c::print-summary ,n-abort-p *aborted-compilation-units*)))) (let ((,n-abort-p t)) (unwind-protect (multiple-value-prog1 (,n-fun) (setq ,n-abort-p nil)) (when ,n-abort-p (incf *aborted-compilation-units*)))))))) cmucl-21a/src/code/mipsstrops.lisp000066400000000000000000000201601260377556400173750ustar00rootroot00000000000000;;; -*- Log: Code.Log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/mipsstrops.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; String hacking functions that are stubs for things that might ;;; be microcoded someday. ;;; ;;; Written by Rob MacLachlan and Skef Wholey ;;; (in-package "SYSTEM") (intl:textdomain "cmucl") (export '(%sp-reverse-find-character-with-attribute)) (in-package "LISP") ;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end) ; "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive) ;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved). Overlap of the ;strings does not affect the result. This would be done on the Vax ;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors ;are also acceptable." ; (%primitive byte-blt src-string src-start dst-string dst-start dst-end)) (defun %sp-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) "Compares the substrings specified by String1 and String2 and returns NIL if the strings are String=, or the lowest index of String1 in which the two differ. If one string is longer than the other and the shorter is a prefix of the longer, the length of the shorter + start1 is returned. This would be done on the Vax with CMPC3. The arguments must be simple strings." (let ((len1 (- end1 start1)) (len2 (- end2 start2))) (declare (fixnum len1 len2)) (cond ((= len1 len2) (do ((index1 start1 (1+ index1)) (index2 start2 (1+ index2))) ((= index1 end1) nil) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1)))) ((> len1 len2) (do ((index1 start1 (1+ index1)) (index2 start2 (1+ index2))) ((= index2 end2) index1) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1)))) (t (do ((index1 start1 (1+ index1)) (index2 start2 (1+ index2))) ((= index1 end1) index1) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1))))))) (defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) "Like %sp-string-compare, only backwards." (let ((len1 (- end1 start1)) (len2 (- end2 start2))) (declare (fixnum len1 len2)) (cond ((= len1 len2) (do ((index1 (1- end1) (1- index1)) (index2 (1- end2) (1- index2))) ((< index1 start1) nil) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1)))) ((> len1 len2) (do ((index1 (1- end1) (1- index1)) (index2 (1- end2) (1- index2))) ((< index2 start2) index1) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1)))) (t (do ((index1 (1- end1) (1- index1)) (index2 (1- end2) (1- index2))) ((< index1 start1) index1) (declare (fixnum index1 index2)) (if (char/= (schar string1 index1) (schar string2 index2)) (return index1))))))) (defmacro maybe-sap-maybe-string ((var) &body body) `(etypecase ,var (system-area-pointer (macrolet ((byte-ref (index) `(sap-ref-8 ,',var ,index)) (char-ref (index) `(code-char (byte-ref ,index)))) ,@body)) (simple-string (macrolet ((char-ref (index) `(schar ,',var ,index)) (byte-ref (index) `(char-code (char-ref ,index)))) ,@body)))) (defun %sp-find-character-with-attribute (string start end table mask) (declare (type (simple-array (unsigned-byte 8) (256)) table) (type (or simple-string system-area-pointer) string) (fixnum start end mask)) "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask The codes of the characters of String from Start to End are used as indices into the Table, which is a U-Vector of 8-bit bytes. When the number picked up from the table bitwise ANDed with Mask is non-zero, the current index into the String is returned. The corresponds to SCANC on the Vax." (maybe-sap-maybe-string (string) (do ((index start (1+ index))) ((>= index end) nil) (declare (fixnum index)) (unless (zerop (logand (aref table (byte-ref index)) mask)) (return index))))) (defun %sp-reverse-find-character-with-attribute (string start end table mask) "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." (declare (type (or simple-string system-area-pointer) string) (fixnum start end mask) (type (array (unsigned-byte 8) (256)) table)) (maybe-sap-maybe-string (string) (do ((index (1- end) (1- index))) ((< index start) nil) (declare (fixnum index)) (unless (zerop (logand (aref table (byte-ref index)) mask)) (return index))))) (defun %sp-find-character (string start end character) "%SP-Find-Character String, Start, End, Character Searches String for the Character from Start to End. If the character is found, the corresponding index into String is returned, otherwise NIL is returned." (declare (fixnum start end) (type (or simple-string system-area-pointer) string) (base-char character)) (maybe-sap-maybe-string (string) (do ((index start (1+ index))) ((>= index end) nil) (declare (fixnum index)) (when (char= (char-ref index) character) (return index))))) (defun %sp-reverse-find-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) "%SP-Reverse-Find-Character String, Start, End, Character Searches String for Character from End to Start. If the character is found, the corresponding index into String is returned, otherwise NIL is returned." (maybe-sap-maybe-string (string) (do ((index (1- end) (1- index)) (terminus (1- start))) ((= index terminus) nil) (declare (fixnum terminus index)) (if (char= (char-ref index) character) (return index))))) (defun %sp-skip-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) "%SP-Skip-Character String, Start, End, Character Returns the index of the first character between Start and End which is not Char= to Character, or NIL if there is no such character." (maybe-sap-maybe-string (string) (do ((index start (1+ index))) ((= index end) nil) (declare (fixnum index)) (if (char/= (char-ref index) character) (return index))))) (defun %sp-reverse-skip-character (string start end character) (declare (type (or simple-string system-area-pointer) string) (fixnum start end) (base-char character)) "%SP-Skip-Character String, Start, End, Character Returns the index of the last character between Start and End which is not Char= to Character, or NIL if there is no such character." (maybe-sap-maybe-string (string) (do ((index (1- end) (1- index)) (terminus (1- start))) ((= index terminus) nil) (declare (fixnum terminus index)) (if (char/= (char-ref index) character) (return index))))) (defun %sp-string-search (string1 start1 end1 string2 start2 end2) "%SP-String-Search String1, Start1, End1, String2, Start2, End2 Searches for the substring of String1 specified in String2. Returns an index into String2 or NIL if the substring wasn't found." (declare (simple-string string1 string2)) (do ((index2 start2 (1+ index2))) ((= index2 end2) nil) (declare (fixnum index2)) (when (do ((index1 start1 (1+ index1)) (index2 index2 (1+ index2))) ((= index1 end1) t) (declare (fixnum index1 index2)) (when (= index2 end2) (return-from %sp-string-search nil)) (when (char/= (char string1 index1) (char string2 index2)) (return nil))) (return index2)))) cmucl-21a/src/code/misc.lisp000066400000000000000000000221271260377556400161120ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/misc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Environment query functions, documentation and dribble. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(documentation *features* variable room lisp-implementation-type lisp-implementation-version machine-type machine-version machine-instance software-type software-version short-site-name long-site-name dribble compiler-macro)) (in-package "SYSTEM") (export '(*software-type* *short-site-name* *long-site-name*)) (in-package "EXT") (export 'featurep) (in-package "LISP") ;;; cobbled from stuff in describe.lisp. (defun function-doc (x) (let ((name (case (kernel:get-type x) (#.vm:closure-header-type (kernel:%function-name (%closure-function x))) ((#.vm:function-header-type #.vm:closure-function-header-type) (kernel:%function-name x)) (#.vm:funcallable-instance-header-type (typecase x (kernel:byte-function (c::byte-function-name x)) (kernel:byte-closure (c::byte-function-name (byte-closure-function x))) (eval:interpreted-function (multiple-value-bind (exp closure-p dname) (eval:interpreted-function-lambda-expression x) (declare (ignore exp closure-p)) dname)) (t ;; funcallable-instance (kernel:%function-name (kernel:funcallable-instance-function x)))))))) (when (and name (typep name '(or symbol cons))) (values (info function documentation name))))) (defun documentation (x doc-type) "Returns the documentation string of Doc-Type for X, or NIL if none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T." (flet (;; CMUCL random-documentation. (try-cmucl-random-doc (x doc-type) (declare (symbol doc-type)) (cdr (assoc doc-type (values (info random-documentation stuff x)))))) (case doc-type (variable (typecase x (symbol (values (info variable documentation x))))) (function (typecase x (symbol (values (info function documentation x))) (function (function-doc x)) (list ;; Must be '(setf symbol) (values (info function documentation (cadr x)))))) (structure (typecase x (symbol (when (eq (info type kind x) :instance) (values (info type documentation x)))))) (type (typecase x (kernel::structure-class (values (info type documentation (%class-name x)))) (t (and (typep x 'symbol) (values (info type documentation x)))))) (setf (info setf documentation x)) ((t) (typecase x (function (function-doc x)) (package (package-doc-string x)) (kernel::structure-class (values (info type documentation (%class-name x)))) (symbol (try-cmucl-random-doc x doc-type)))) (t (typecase x (symbol (try-cmucl-random-doc x doc-type))))))) (defun (setf documentation) (string name doc-type) #-no-docstrings (case doc-type (variable #+nil (when string (%primitive print "Set variable text domain") (%primitive print (symbol-name name)) (%primitive print intl::*default-domain*)) (setf (info variable textdomain name) intl::*default-domain*) (setf (info variable documentation name) string)) (function #+nil (when intl::*default-domain* (%primitive print "Set function text domain") (%primitive print (symbol-name name)) (%primitive print intl::*default-domain*)) (setf (info function textdomain name) intl::*default-domain*) (setf (info function documentation name) string)) (structure (unless (eq (info type kind name) :instance) (error (intl:gettext "~S is not the name of a structure type.") name)) (setf (info type textdomain name) intl::*default-domain*) (setf (info type documentation name) string)) (type (setf (info type textdomain name) intl::*default-domain*) (setf (info type documentation name) string)) (setf (setf (info setf textdomain name) intl::*default-domain*) (setf (info setf documentation name) string)) (t (let ((pair (assoc doc-type (info random-documentation stuff name)))) (if pair (setf (cdr pair) string) (push (cons doc-type string) (info random-documentation stuff name)))))) string) ;;; Register various Lisp features #+sparc-v7 (sys:register-lisp-runtime-feature :sparc-v7) #+sparc-v8 (sys:register-lisp-runtime-feature :sparc-v8) #+sparc-v9 (sys:register-lisp-runtime-feature :sparc-v9) #+complex-fp-vops (sys:register-lisp-feature :complex-fp-vops) #+unicode (sys:register-lisp-runtime-feature :unicode) #+cmu (sys:register-lisp-feature :cmu) #+(or cmu cmucl) (sys:register-lisp-feature :cmucl) (defun featurep (x) "If X is an atom, see if it is present in *FEATURES*. Also handle arbitrary combinations of atoms using NOT, AND, OR." (if (consp x) (case (car x) ((:not not) (not (featurep (cadr x)))) ((:and and) (every #'featurep (cdr x))) ((:or or) (some #'featurep (cdr x))) (t (error (intl:gettext "Unknown operator in feature expression: ~S.") x))) (not (null (memq x *features*))))) ;;; Other Environment Inquiries. (defun lisp-implementation-type () "Returns a string describing the implementation type." "CMU Common Lisp") (defun lisp-implementation-version () "Returns a string describing the implementation version." (format nil "~A (~X~A)" *lisp-implementation-version* c:byte-fasl-file-version #+unicode _" Unicode" #-unicode "")) (defun machine-instance () "Returns a string giving the name of the local machine." (unix:unix-gethostname)) (defvar *software-type* "Unix" "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") (defun software-type () "Returns a string describing the supporting software." *software-type*) (defvar *short-site-name* (intl:gettext "Unknown") "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.") (defun short-site-name () "Returns a string with the abbreviated site name." *short-site-name*) (defvar *long-site-name* (intl:gettext "Site name not initialized") "The value of LONG-SITE-NAME. Set in library:site-init.lisp.") (defun long-site-name () "Returns a string with the long form of the site name." *long-site-name*) ;;;; Dribble stuff: ;;; Each time we start dribbling to a new stream, we put it in ;;; *dribble-stream*, and push a list of *dribble-stream*, *standard-input*, ;;; *standard-output* and *error-output* in *previous-streams*. ;;; *standard-output* and *error-output* is changed to a broadcast stream that ;;; broadcasts to *dribble-stream* and to the old values of the variables. ;;; *standard-input* is changed to an echo stream that echos input from the old ;;; value of standard input to *dribble-stream*. ;;; ;;; When dribble is called with no arguments, *dribble-stream* is closed, ;;; and the values of *dribble-stream*, *standard-input*, and ;;; *standard-output* are poped from *previous-streams*. (defvar *previous-streams* nil) (defvar *dribble-stream* nil) (defun dribble (&optional pathname &key (if-exists :append)) "With a file name as an argument, dribble opens the file and sends a record of further I/O to that file. Without an argument, it closes the dribble file, and quits logging." (cond (pathname (let* ((new-dribble-stream (open pathname :direction :output :if-exists if-exists :if-does-not-exist :create)) (new-standard-output (make-broadcast-stream *standard-output* new-dribble-stream)) (new-error-output (make-broadcast-stream *error-output* new-dribble-stream)) (new-standard-input (make-echo-stream *standard-input* new-dribble-stream))) (push (list *dribble-stream* *standard-input* *standard-output* *error-output*) *previous-streams*) (setf *dribble-stream* new-dribble-stream) (setf *standard-input* new-standard-input) (setf *standard-output* new-standard-output) (setf *error-output* new-error-output))) ((null *dribble-stream*) (error (intl:gettext "Not currently dribbling."))) (t (let ((old-streams (pop *previous-streams*))) (close *dribble-stream*) (setf *dribble-stream* (first old-streams)) (setf *standard-input* (second old-streams)) (setf *standard-output* (third old-streams)) (setf *error-output* (fourth old-streams))))) (values)) (defun ed (&optional x) "Default implementation of ed. This does nothing. If hemlock is loaded, ed can be used to edit a file" (declare (ignorable x)) (values)) (defun disassemble (object) "Disassemble the machine code associated with OBJECT, which can be a function, a lambda expression, or a symbol with a function definition. If it is not already compiled, the compiler is called to produce something to disassemble." (disassem:disassemble object)) cmucl-21a/src/code/module.lisp000066400000000000000000000132251260377556400164430ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/module.lisp $") ;;; ;;; ********************************************************************** ;;; Code written by Jim Muller. ;;; Rewritten by Bill Chiles. ;;; ;;; Note that this module file is based on the old system, and is being ;;; spliced into the current sources to reflect the last minute deprecated ;;; addition of modules to the X3J13 ANSI standard. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(*modules* provide require)) (in-package "EXTENSIONS") (export '(*require-verbose* *module-provider-functions* defmodule)) (in-package "LISP") ;;;; Exported specials. (defvar *modules* () "This is a list of module names that have been loaded into Lisp so far. It is used by PROVIDE and REQUIRE.") (defvar *require-verbose* t "*load-verbose* is bound to this before loading files.") (defvar *module-provider-functions* '(module-provide-cmucl-defmodule module-provide-cmucl-library) "See function documentation for REQUIRE") ;;;; Defmodule. (defvar *module-file-translations* (make-hash-table :test #'equal)) (defmacro defmodule (name &rest files) "Defines a module by registering the files that need to be loaded when the module is required. If name is a symbol, its print name is used after downcasing it." `(%define-module ,name ',files)) (defun %define-module (name files) (setf (gethash (module-name-string name) *module-file-translations*) files)) (defun module-files (name) (gethash name *module-file-translations*)) ;;;; Provide and Require. (defun provide (module-name) "Adds a new module name to *modules* indicating that it has been loaded. Module-name may be any valid string designator. All comparisons are done using string=, i.e. module names are case-sensitive." (pushnew (module-name-string module-name) *modules* :test #'string=) t) (defun require (module-name &optional pathname) "Loads a module when it has not been already. Pathname, if supplied, is a single pathname or list of pathnames to be loaded if the module needs to be. If pathname is not supplied, then functions from the list *MODULE-PROVIDER-FUNCTIONS* are called in order with the stringified MODULE-NAME as the argument, until one of them returns non-NIL. By default the functions MODULE-PROVIDE-CMUCL-DEFMODULE and MODULE-PROVIDE- CMUCL-LIBRARY are on this list of functions, in that order. The first of those looks for a list of files that was registered by a EXT:DEFMODULE form. If the module has not been defined, then the second function causes a file to be loaded whose name is formed by merging \"modules:\" and the concatenation of module-name with the suffix \"-LIBRARY\". Note that both the module-name and the suffix are each, separately, converted from :case :common to :case :local. This merged name will be probed with both a .lisp and .fasl extensions, calling LOAD if it exists. Note that in all cases covered above, user code is responsible for calling PROVIDE to indicate a successful load of the module. While loading any files, *load-verbose* is bound to *require-verbose* which defaults to t." (let ((saved-modules (copy-list *modules*)) (module-name (module-name-string module-name))) (unless (member module-name *modules* :test #'string=) (let ((*load-verbose* *require-verbose*)) (if pathname (dolist (file (if (consp pathname) pathname (list pathname)) t) (load file)) (unless (some (lambda (p) (funcall p module-name)) *module-provider-functions*) (error (intl:gettext "Don't know how to load ~A") module-name))))) (set-difference *modules* saved-modules))) ;;;; Default module providers (defun module-provide-cmucl-defmodule (module-name) (when (module-files module-name) (dolist (file (module-files module-name) t) (load file)))) (defun module-provide-cmucl-library (module-name) (ext:without-package-locks (load (module-default-pathname module-name) :if-does-not-exist nil))) ;;;; Misc. (defun module-name-string (name) "Coerce a string designator to a module name." (string name)) (defun module-default-pathname (module-name) "Derive a default pathname to try to load for an undefined module named module-name. The default pathname is constructed from the module-name by appending the suffix \"-LIBRARY\" to it, and merging with \"modules:\". Note that both the module-name and the suffix are each, separately, converted from :case :common to :case :local." (let* ((module-pathname (make-pathname :name module-name :case :common)) (library-pathname (make-pathname :name "-LIBRARY" :case :common))) (merge-pathnames "modules:" (make-pathname :name (concatenate 'string (pathname-name module-pathname :case :local) (pathname-name library-pathname :case :local)) :case :local)))) (defmodule :defsystem "modules:defsystem/defsystem") ;; Allow user to load asdf using either (require :asdf) or (require ;; "asdf") (defmodule :asdf "modules:asdf/asdf") (defmodule "asdf" "modules:asdf/asdf") ;; Lisp-unit (defmodule :lisp-unit "modules:load-lisp-unit") (defmodule "lisp-unit" "modules:load-lisp-unit") ;; Allow user to specify "cmu-contribs" or :cmu-contribs. (defmodule "cmu-contribs" "modules:contrib") (defmodule :cmu-contribs "modules:contrib") (defmodule :unix "modules:load-unix") cmucl-21a/src/code/multi-proc.lisp000066400000000000000000002173641260377556400172630ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Multiprocessing -*- ;;; ;;; ********************************************************************** ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the Public domain, and is provided 'as is'. ;;; (ext:file-comment "$Header: src/code/multi-proc.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Stack-group and multi-process support for CMUCL x86. ;;; (in-package "MULTIPROCESSING") (intl:textdomain "cmucl-mp") (sys:register-lisp-runtime-feature :mp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Handle the binding stack. ;;; Undo all the bindings in the bind stack, restoring the global ;;; values. (defun unbind-binding-stack () (declare (optimize (speed 3) (safety 0))) (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) (binding-stack (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) (size (sys:sap- binding-stack-pointer binding-stack))) (declare (type (unsigned-byte 29) size)) (do ((binding size)) ((zerop binding)) (declare (type (unsigned-byte 29) binding)) (decf binding 8) (let* ((value (kernel:make-lisp-obj (sys:sap-int (sys:sap-ref-sap binding-stack binding)))) (symbol (kernel:make-lisp-obj (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4)))))) (cond ((symbolp symbol) (let ((symbol-value (c::%primitive c:fast-symbol-value symbol))) #+nil (format t "Undoing: ~s ~s <-> ~s~%" symbol value symbol-value) (kernel:%set-symbol-value symbol value) (setf (sys:sap-ref-sap binding-stack binding) (sys:int-sap (kernel:get-lisp-obj-address symbol-value))))) (t #+nil (format t "Ignoring undoing: ~s ~s~%" symbol value))))))) ;;; Re-apply the bindings in a binding stack after an ;;; unbind-binding-stack. (defun rebind-binding-stack () (declare (optimize (speed 3) (safety 0))) (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) (binding-stack (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) (size (sys:sap- binding-stack-pointer binding-stack))) (declare (type (unsigned-byte 29) size)) (do ((binding 0 (+ 8 binding))) ((= binding size)) (declare (type (unsigned-byte 29) binding)) (let* ((value (kernel:make-lisp-obj (sys:sap-int (sys:sap-ref-sap binding-stack binding)))) (symbol (kernel:make-lisp-obj (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4)))))) (cond ((symbolp symbol) (let ((symbol-value (c::%primitive c:fast-symbol-value symbol))) #+nil (format t "Rebinding: ~s ~s <-> ~s~%" symbol value symbol-value) (kernel:%set-symbol-value symbol value) (setf (sys:sap-ref-sap binding-stack binding) (sys:int-sap (kernel:get-lisp-obj-address symbol-value))))) (t #+nil (format t "Ignoring rebinding: ~s ~s~%" symbol value))))))) (defun save-binding-stack (binding-save-stack) (declare (type (simple-array t (*)) binding-save-stack) (optimize (speed 3) (safety 0))) (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap)) (binding-stack (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned))) (size (sys:sap- binding-stack-pointer binding-stack)) (vector-size (truncate size 4))) (declare (type (unsigned-byte 29) size)) ;; Grow binding-save-stack if necessary. (when (< (length binding-save-stack) vector-size) (setq binding-save-stack (adjust-array binding-save-stack vector-size :element-type t))) ;; Save the stack. (do ((binding 0 (+ 4 binding)) (index 0 (1+ index))) ((= binding size)) (declare (type (unsigned-byte 29) binding index)) (setf (aref binding-save-stack index) (kernel:make-lisp-obj (sys:sap-int (sys:sap-ref-sap binding-stack binding))))) (values binding-save-stack vector-size))) (defun restore-binding-stack (new-binding-stack size) (declare (type (simple-array t (*)) new-binding-stack) (type (unsigned-byte 29) size) (optimize (speed 3) (safety 0))) (let* ((binding-stack-size (* size 4)) (binding-stack (alien:extern-alien "binding_stack" alien:unsigned))) (declare (type (unsigned-byte 32) binding-stack-size binding-stack)) (setf (kernel:binding-stack-pointer-sap) (sys:int-sap (+ binding-stack binding-stack-size))) (do ((binding 0 (+ 4 binding)) (index 0 (1+ index))) ((= binding binding-stack-size)) (declare (type (unsigned-byte 29) binding index)) (setf (sys:sap-ref-sap (sys:int-sap binding-stack) binding) (sys:int-sap (kernel:get-lisp-obj-address (aref new-binding-stack index)))))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Alien-stack ;;; The Top of the Alien-stack. (declaim (type (unsigned-byte 32) *alien-stack-top*)) (defvar *alien-stack-top* 0) ;;; Save the alien-stack. (defun save-alien-stack (save-stack) (declare (type (simple-array (unsigned-byte 32) (*)) save-stack) (optimize (speed 3) (safety 0))) (let* ((alien-stack (kernel:get-lisp-obj-address x86::*alien-stack*)) (size (- *alien-stack-top* alien-stack)) (vector-size (ceiling size 4))) (declare (type (unsigned-byte 32) alien-stack) (type (unsigned-byte 29) size)) #+nil (format t "alien-stack ~x; size ~x~%" alien-stack size) ;; Grow save-stack if necessary. (when (< (length save-stack) vector-size) (setq save-stack (adjust-array save-stack vector-size :element-type '(unsigned-byte 32)))) ;; Save the stack. (do ((index 0 (1+ index))) ((>= index vector-size)) (declare (type (unsigned-byte 29) index)) (setf (aref save-stack index) (sys:sap-ref-32 (sys:int-sap *alien-stack-top*) (* 4 (- (1+ index)))))) (values save-stack vector-size alien-stack))) (defun restore-alien-stack (save-stack size alien-stack) (declare (type (simple-array (unsigned-byte 32) (*)) save-stack) (type (unsigned-byte 29) size) (type (unsigned-byte 32) alien-stack) (optimize (speed 3) (safety 0))) (setf x86::*alien-stack* (kernel:make-lisp-obj alien-stack)) (do ((index 0 (1+ index))) ((>= index size)) (declare (type (unsigned-byte 29) index)) (setf (sys:sap-ref-32 (sys:int-sap *alien-stack-top*) (* 4 (- (1+ index)))) (aref save-stack index))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Interrupt contexts. ;;; Save the interrupt contexts. (defun save-interrupt-contexts (save-vector) (declare (type (simple-array (unsigned-byte 32) (*)) save-vector) (optimize (speed 3) (safety 0))) (let* ((size lisp::*free-interrupt-context-index*)) (declare (type (unsigned-byte 29) size)) ;; Grow save-stack if necessary. (when (< (length save-vector) size) (setq save-vector (adjust-array save-vector size :element-type '(unsigned-byte 32)))) (alien:with-alien ((lisp-interrupt-contexts (array alien:unsigned nil) :extern)) (dotimes (index size) (setf (aref save-vector index) (alien:deref lisp-interrupt-contexts index)))) save-vector)) ;;; Restore the interrupt contexts. (defun restore-interrupt-contexts (save-vector) (declare (type (simple-array (unsigned-byte 32) (*)) save-vector) (optimize (speed 3) (safety 0))) (let* ((size lisp::*free-interrupt-context-index*)) (declare (type (unsigned-byte 29) size)) (alien:with-alien ((lisp-interrupt-contexts (array alien:unsigned nil) :extern)) (dotimes (index size) (setf (alien:deref lisp-interrupt-contexts index) (aref save-vector index))))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;; The control stacks need special handling on the x86 as they ;;; contain conservative roots. When placed in the *control-stacks* ;;; vector they will be scavenged for conservative roots by the ;;; garbage collector. (declaim (type (simple-array (or null (simple-array (unsigned-byte 32) (*))) (*)) x86::*control-stacks*)) (defvar x86::*control-stacks* (make-array 0 :element-type '(or null (unsigned-byte 32)) :initial-element nil)) ;;; Stack-group structure. (defstruct (stack-group (:constructor %make-stack-group) (:print-function (lambda (stack-group stream depth) (declare (type stack-group stack-group) (stream stream) (ignore depth)) (print-unreadable-object (stack-group stream :identity t) (format stream "Stack-group ~a, ~a" (stack-group-name stack-group) (stack-group-state stack-group)))))) ;; Must have a name. (name "Anonymous" :type simple-base-string) ;; State: :active or :inactive. (state :inactive :type (member :active :inactive)) ;; The control stack; an index into *control-stacks*. (control-stack-id nil :type (or kernel:index null)) ;; Binding stack. (binding-stack nil :type (or (simple-array t (*)) null)) ;; Twice the number of bindings. (binding-stack-size 0 :type (unsigned-byte 29)) ;; Current catch block, on the control stack. (current-catch-block 0 :type fixnum) ;; Unwind protect block, on the control stack. (current-unwind-protect-block 0 :type fixnum) ;; Alien stack (alien-stack nil :type (or (simple-array (unsigned-byte 32) (*)) null)) (alien-stack-size 0 :type (unsigned-byte 29)) (alien-stack-pointer 0 :type (unsigned-byte 32)) ;; Eval-stack (eval-stack nil :type (or (simple-array t (*)) null)) (eval-stack-top 0 :type fixnum) ;; ;; Interrupt contexts (interrupt-contexts nil :type (or (simple-array (unsigned-byte 32) (*)) null)) ;; Resumer (resumer nil :type (or stack-group null))) ;;; The current stack group. (declaim (type (or stack-group null) *current-stack-group*)) (defvar *current-stack-group* nil) (declaim (type (or stack-group null) *initial-stack-group*)) (defvar *initial-stack-group* nil) ;;; Process defstruct is up here because stack group functions refer ;;; to process slots in assertions, but are also compiled at high ;;; optimization... so if the process structure changes, all hell ;;; could break loose. (defstruct (process (:constructor %make-process) (:predicate processp) (:print-function (lambda (process stream depth) (declare (type process process) (stream stream) (ignore depth)) (print-unreadable-object (process stream :identity t) (format stream "Process ~a" (process-name process)))))) (name "Anonymous" :type simple-base-string) (state :killed :type (member :killed :active :inactive)) (%whostate nil :type (or null simple-base-string)) (initial-function nil :type (or null function)) (initial-args nil :type list) (wait-function nil :type (or null function)) (wait-function-args nil :type list) (%run-reasons nil :type list) (%arrest-reasons nil :type list) ;; The real time after which the wait will timeout. (wait-timeout nil :type (or null double-float)) (wait-return-value nil :type t) (interrupts '() :type list) (stack-group nil :type (or null stack-group)) ;; ;; The real and run times when the current process was last ;; scheduled or yielded. (scheduled-real-time (get-real-time) :type double-float) (scheduled-run-time (get-run-time) :type double-float) ;; ;; Accrued real and run times in seconds. (%real-time 0d0 :type double-float) (%run-time 0d0 :type double-float) (property-list nil :type list) (%return-values nil :type list) (initial-bindings nil :type list)) ;;; Init-Stack-Groups -- Interface ;;; ;;; Setup the initial stack group. ;;; (defun init-stack-groups () ;; Grab the top of the alien-stack; it's currently stored at the top ;; of the control stack. (setf *alien-stack-top* (sys:sap-ref-32 (sys:int-sap (alien:extern-alien "control_stack_end" alien:unsigned)) -4)) ;; Initialise the *control-stacks* vector. (setq x86::*control-stacks* (make-array 10 :element-type '(or null (unsigned-byte 32)) :initial-element nil)) ;; Setup a control-stack for the initial stack-group. (setf (aref x86::*control-stacks* 0) (make-array 0 :element-type '(unsigned-byte 32) :initial-element 0)) ;; Make and return the initial stack group. (setf *current-stack-group* (%make-stack-group :name "Initial" :state :active :control-stack-id 0 :binding-stack #() :alien-stack (make-array 0 :element-type '(unsigned-byte 32)) :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32)) :eval-stack #())) (setf *initial-stack-group* *current-stack-group*)) ;;; Inactivate-Stack-Group -- Internal ;;; ;;; Inactivate the stack group, cleaning its slot and freeing the ;;; control stack. ;;; (defun inactivate-stack-group (stack-group) (declare (type stack-group stack-group)) (setf (stack-group-state stack-group) :inactive) (let ((cs-id (stack-group-control-stack-id stack-group))) (when (and cs-id (aref x86::*control-stacks* cs-id)) (setf (aref x86::*control-stacks* cs-id) nil))) (setf (stack-group-control-stack-id stack-group) nil) (setf (stack-group-binding-stack stack-group) nil) (setf (stack-group-binding-stack-size stack-group) 0) (setf (stack-group-current-catch-block stack-group) 0) (setf (stack-group-current-unwind-protect-block stack-group) 0) (setf (stack-group-alien-stack stack-group) nil) (setf (stack-group-alien-stack-size stack-group) 0) (setf (stack-group-alien-stack-pointer stack-group) 0) (setf (stack-group-eval-stack stack-group) nil) (setf (stack-group-eval-stack-top stack-group) 0) (setf (stack-group-resumer stack-group) nil)) ;;; Scrub-Stack-Group-Stacks -- Internal ;;; ;;; Scrub the binding and eval stack of the give stack-group. ;;; (defun scrub-stack-group-stacks (stack-group) (declare (type stack-group stack-group) (optimize (speed 3) (safety 0))) ;; Binding stack. (let ((binding-save-stack (stack-group-binding-stack stack-group))) (when binding-save-stack (let ((size ;; The stored binding stack for the current stack group ;; can be completely scrubbed. (if (eq stack-group *current-stack-group*) 0 (stack-group-binding-stack-size stack-group))) (len (length binding-save-stack))) ;; Scrub the remainder of the binding stack. (do ((index size (+ index 1))) ((>= index len)) (declare (type (unsigned-byte 29) index)) (setf (aref binding-save-stack index) 0))))) ;; If this is the current stack group then update the stored ;; eval-stack and eval-stack-top before scrubbing. (when (eq stack-group *current-stack-group*) ;; Updare the stored vector, flushing an old vector if a new one ;; has been allocated. (setf (stack-group-eval-stack stack-group) lisp::*eval-stack*) ;; Ensure that the stack-top is valid. (setf (stack-group-eval-stack-top stack-group) lisp::*eval-stack-top*)) ;; Scrub the eval stack. (let ((eval-stack (stack-group-eval-stack stack-group))) (when eval-stack (let ((eval-stack-top (stack-group-eval-stack-top stack-group)) (len (length eval-stack))) (do ((i eval-stack-top (1+ i))) ((= i len)) (declare (type kernel:index i)) (setf (svref eval-stack i) nil)))))) ;;; Initial-binding-stack -- Internal ;;; ;;; Generate the initial bindings for a newly created stack-group. ;;; This function may be redefined to return a vector with other bindings ;;; but *interrupts-enabled* and *gc-inhibit* must be the last two. ;;; (defun initial-binding-stack () (vector (find-package "COMMON-LISP-USER") '*package* ;; Other bindings may be added here. nil 'unix::*interrupts-enabled* t 'lisp::*gc-inhibit*)) ;;; Make-Stack-Group -- Interface ;;; ;;; Fork a new stack-group from the *current-stack-group*. Execution ;;; continues with the *current-stack-group* returning the new stack ;;; group. Control may be transfer to the child by stack-group-resume ;;; and it executes the initial-function. ;;; (defun make-stack-group (name initial-function &optional (resumer *current-stack-group*) (inherit t)) (declare (type simple-base-string name) (type function initial-function) (type stack-group resumer)) (flet ((allocate-control-stack () (let* (;; Allocate a new control-stack ID. (control-stack-id (position nil x86::*control-stacks*)) ;; Find the required stack size. (control-stack-end (alien:extern-alien "control_stack_end" alien:unsigned)) (control-stack-pointer (kernel:control-stack-pointer-sap)) (control-stack-size (- control-stack-end (sys:sap-int control-stack-pointer))) ;; Saved control stack needs three extra words. The ;; stack pointer will be stored in the first ;; element, and the frame pointer and return address ;; push onto the bottom of the stack. (control-stack (make-array (+ (ceiling control-stack-size 4) 3) :element-type '(unsigned-byte 32) :initial-element 0))) (declare (type (unsigned-byte 29) control-stack-size)) (unless control-stack-id ;; Need to extend the *control-stacks* vector. (setq control-stack-id (length x86::*control-stacks*)) (setq x86::*control-stacks* (adjust-array x86::*control-stacks* (* 2 (length x86::*control-stacks*)) :element-type '(or null (unsigned-byte 32)) :initial-element nil))) (setf (aref x86::*control-stacks* control-stack-id) control-stack) (values control-stack control-stack-id))) ;; Allocate a stack group inheriting stacks and bindings from ;; the current stack group. (allocate-child-stack-group (control-stack-id) ;; Save the interrupt-contexts while the size is still ;; bound. (let ((interrupt-contexts (save-interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32))))) ;; Save the binding stack. Note that ;; *interrutps-enabled* could be briefly set during the ;; unbinding and re-binding process so signals are ;; blocked. (let ((old-sigs (unix:unix-sigblock (unix:sigmask :sigint :sigalrm)))) (declare (type (unsigned-byte 32) old-sigs)) (unbind-binding-stack) (multiple-value-bind (binding-stack binding-stack-size) (save-binding-stack #()) (rebind-binding-stack) (unix:unix-sigsetmask old-sigs) ;; Save the Alien stack (multiple-value-bind (alien-stack alien-stack-size alien-stack-pointer) (save-alien-stack (make-array 0 :element-type '(unsigned-byte 32))) ;; Allocate a stack-group structure. (%make-stack-group :name name :state :active :control-stack-id control-stack-id ;; Save the Eval stack. :eval-stack (copy-seq (the simple-vector kernel:*eval-stack*)) :eval-stack-top kernel:*eval-stack-top* ;; Misc stacks. :current-catch-block lisp::*current-catch-block* :current-unwind-protect-block lisp::*current-unwind-protect-block* ;; Alien stack. :alien-stack alien-stack :alien-stack-size alien-stack-size :alien-stack-pointer alien-stack-pointer ;; Interrupt contexts :interrupt-contexts interrupt-contexts ;; Binding stack. :binding-stack binding-stack :binding-stack-size binding-stack-size ;; Resumer :resumer resumer)))))) ;; Allocate a new stack group with fresh stacks and bindings. (allocate-new-stack-group (control-stack-id) (let ((binding-stack (initial-binding-stack))) ;; Allocate a stack-group structure. (%make-stack-group :name name :state :active :control-stack-id control-stack-id ;; Eval stack. Needs at least one element be because ;; push doubles the size when full. :eval-stack (make-array 32) :eval-stack-top 0 ;; Misc stacks. :current-catch-block 0 :current-unwind-protect-block 0 ;; Alien stack. :alien-stack (make-array 0 :element-type '(unsigned-byte 32)) :alien-stack-size 0 :alien-stack-pointer *alien-stack-top* ;; Interrupt contexts :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32)) ;; Binding stack - some initial bindings. :binding-stack binding-stack :binding-stack-size (length binding-stack) ;; Resumer :resumer resumer)))) (let ((child-stack-group nil)) (let ((unix::*interrupts-enabled* nil) (lisp::*gc-inhibit* t)) (multiple-value-bind (control-stack control-stack-id) (allocate-control-stack) (setq child-stack-group (if inherit (allocate-child-stack-group control-stack-id) (allocate-new-stack-group control-stack-id))) ;; Fork the control-stack (if (x86:control-stack-fork control-stack inherit) ;; Current-stack-group returns the child-stack-group. child-stack-group ;; Child starts. (unwind-protect (progn (setq *current-stack-group* child-stack-group) (assert (eq *current-stack-group* (process-stack-group *current-process*))) ;; Enable interrupts and GC. (setf unix::*interrupts-enabled* t) (setf lisp::*gc-inhibit* nil) (when unix::*interrupt-pending* (unix::do-pending-interrupt)) (when lisp::*need-to-collect-garbage* (lisp::maybe-gc)) (funcall initial-function)) (let ((resumer (stack-group-resumer child-stack-group))) ;; Disable interrupts and GC. (setf unix::*interrupts-enabled* nil) (setf lisp::*gc-inhibit* t) (inactivate-stack-group child-stack-group) ;; Verify the resumer. (unless (and resumer (eq (stack-group-state resumer) :active)) (format t "*Resuming stack-group ~s instead of ~s~%" *initial-stack-group* resumer) (setq resumer *initial-stack-group*)) ;; Restore the resumer state. (setq *current-stack-group* resumer) ;; Eval-stack (setf kernel:*eval-stack* (stack-group-eval-stack resumer)) (setf kernel:*eval-stack-top* (stack-group-eval-stack-top resumer)) ;; The binding stack. Note that ;; *interrutps-enabled* could be briefly set during ;; the unbinding and re-binding process so signals ;; are blocked. (let ((old-sigs (unix:unix-sigblock (unix:sigmask :sigint :sigalrm)))) (declare (type (unsigned-byte 32) old-sigs)) (unbind-binding-stack) (restore-binding-stack (stack-group-binding-stack resumer) (stack-group-binding-stack-size resumer)) (rebind-binding-stack) (unix:unix-sigsetmask old-sigs)) ;; Misc stacks. (setf lisp::*current-catch-block* (stack-group-current-catch-block resumer)) (setf lisp::*current-unwind-protect-block* (stack-group-current-unwind-protect-block resumer)) ;; The Alien stack (restore-alien-stack (stack-group-alien-stack resumer) (stack-group-alien-stack-size resumer) (stack-group-alien-stack-pointer resumer)) ;; Interrupt-contexts. (restore-interrupt-contexts (stack-group-interrupt-contexts resumer)) ;; (let ((new-control-stack (aref x86::*control-stacks* (stack-group-control-stack-id resumer)))) (declare (type (simple-array (unsigned-byte 32) (*)) new-control-stack)) (x86:control-stack-return new-control-stack))))))) (when (and unix::*interrupts-enabled* unix::*interrupt-pending*) (unix::do-pending-interrupt)) (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*)) (lisp::maybe-gc)) child-stack-group))) ;;; Stack-Group-Resume -- Interface ;;; ;;; Transfer control to the given stack-group, resuming its execution, ;;; and saving the *current-stack-group*. ;;; (defun stack-group-resume (new-stack-group) (declare (type stack-group new-stack-group) (optimize (speed 3))) (assert (and (eq (stack-group-state new-stack-group) :active) (not (eq new-stack-group *current-stack-group*)))) (assert (eq new-stack-group (process-stack-group *current-process*))) (let ((unix::*interrupts-enabled* nil) (lisp::*gc-inhibit* t)) (let* (;; Save the current stack-group on its stack. (stack-group *current-stack-group*) ;; Find the required stack size. (control-stack-end (alien:extern-alien "control_stack_end" alien:unsigned)) (control-stack-pointer (kernel:control-stack-pointer-sap)) (control-stack-size (- control-stack-end (sys:sap-int control-stack-pointer))) ;; Stack-save array needs three extra elements. The stack ;; pointer will be stored in the first, and the frame ;; pointer and return address push onto the bottom of the ;; stack. (save-stack-size (+ (ceiling control-stack-size 4) 3)) ;; The save-stack vector. (control-stack (aref x86::*control-stacks* (stack-group-control-stack-id stack-group)))) (declare (type (unsigned-byte 29) control-stack-size save-stack-size) (type (simple-array (unsigned-byte 32) (*)) control-stack)) ;; Increase the save-stack size if necessary. (when (> save-stack-size (length control-stack)) (setf control-stack (adjust-array control-stack save-stack-size :element-type '(unsigned-byte 32) :initial-element 0)) (setf (aref x86::*control-stacks* (stack-group-control-stack-id stack-group)) control-stack)) ;; Eval-stack (setf (stack-group-eval-stack stack-group) kernel:*eval-stack*) (setf (stack-group-eval-stack-top stack-group) kernel:*eval-stack-top*) (setf kernel:*eval-stack* (stack-group-eval-stack new-stack-group)) (setf kernel:*eval-stack-top* (stack-group-eval-stack-top new-stack-group)) ;; Misc stacks. (setf (stack-group-current-catch-block stack-group) lisp::*current-catch-block*) (setf (stack-group-current-unwind-protect-block stack-group) lisp::*current-unwind-protect-block*) (setf lisp::*current-catch-block* (stack-group-current-catch-block new-stack-group)) (setf lisp::*current-unwind-protect-block* (stack-group-current-unwind-protect-block new-stack-group)) ;; Save the interrupt-contexts. (setf (stack-group-interrupt-contexts stack-group) (save-interrupt-contexts (stack-group-interrupt-contexts stack-group))) ;; The binding stack. Note that *interrutps-enabled* could be ;; briefly set during the unbinding and re-binding process so ;; signals are blocked. (let ((old-sigs (unix:unix-sigblock (unix:sigmask :sigint :sigalrm)))) (declare (type (unsigned-byte 32) old-sigs)) (unbind-binding-stack) (multiple-value-bind (stack size) (save-binding-stack (stack-group-binding-stack stack-group)) (setf (stack-group-binding-stack stack-group) stack) (setf (stack-group-binding-stack-size stack-group) size)) (restore-binding-stack (stack-group-binding-stack new-stack-group) (stack-group-binding-stack-size new-stack-group)) (rebind-binding-stack) (unix:unix-sigsetmask old-sigs)) ;; Restore the interrupt-contexts. (restore-interrupt-contexts (stack-group-interrupt-contexts new-stack-group)) ;; The Alien stack (multiple-value-bind (save-stack size alien-stack) (save-alien-stack (stack-group-alien-stack stack-group)) (setf (stack-group-alien-stack stack-group) save-stack) (setf (stack-group-alien-stack-size stack-group) size) (setf (stack-group-alien-stack-pointer stack-group) alien-stack)) (restore-alien-stack (stack-group-alien-stack new-stack-group) (stack-group-alien-stack-size new-stack-group) (stack-group-alien-stack-pointer new-stack-group)) ;; (let ((new-control-stack (aref x86::*control-stacks* (stack-group-control-stack-id new-stack-group)))) (declare (type (simple-array (unsigned-byte 32) (*)) new-control-stack)) (x86:control-stack-resume control-stack new-control-stack)) ;; Thread returns. (setq *current-stack-group* stack-group))) (assert (eq *current-stack-group* (process-stack-group *current-process*))) (when (and unix::*interrupts-enabled* unix::*interrupt-pending*) (unix::do-pending-interrupt)) (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*)) (lisp::maybe-gc)) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Double-float timing functions for use by the scheduler. ;;; These timer functions use double-floats for accuracy. In most ;;; cases consing is avoided. ;;; Get-Real-Time ;;; (declaim (inline get-real-time)) ;;; (defun get-real-time () "Return the real time in seconds." (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday) (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) (+ (coerce seconds 'double-float) (* (coerce useconds 'double-float) 1d-6)))) ;;; Get-Run-Time ;;; (declaim (inline get-run-time)) ;;; (defun get-run-time () "Return the run time in seconds" (declare (optimize (speed 3) (safety 0))) (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) (unix:unix-fast-getrusage unix:rusage_self) (declare (ignore ignore) (type (unsigned-byte 31) utime-sec stime-sec) (type (mod 1000000) utime-usec stime-usec)) (+ (coerce utime-sec 'double-float) (coerce stime-sec 'double-float) (* (+ (coerce utime-usec 'double-float) (coerce stime-usec 'double-float)) 1d-6)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Multi-process support. The interface is based roughly on the ;;;; CLIM-SYS spec. and support needed for cl-http. (defvar *multi-processing* t) ;;; Process-Whostate -- Public ;;; (defun process-whostate (process) "Return the process state which is either Run, Killed, or a wait reason." (cond ((eq (process-state process) :killed) "Killed") ((process-wait-function process) (or (process-%whostate process) "Run")) (t "Run"))) ;;; Process-Active-P -- Public ;;; (declaim (inline process-active-p)) (defun process-active-p (process) (and (eq (process-state process) :active) (process-%run-reasons process) (not (process-%arrest-reasons process)))) ;;; Process-Alive-P -- Public ;;; (declaim (inline process-alive-p)) (defun process-alive-p (process) (let ((state (process-state process))) (or (eq state :active) (eq state :inactive)))) ;;; A dummy initial process is defined so that locks will work before ;;; multi-processing has been started. (declaim (type process *current-process*)) (defvar *current-process* (%make-process :name "Startup" :state :inactive :stack-group nil)) ;;; Current-Process -- Public ;;; (declaim (inline current-process)) (defun current-process () "Returns the current process." *current-process*) (declaim (list *all-processes*)) (defvar *all-processes* nil "A list of all alive processes.") ;;; All-Processes -- Public ;;; (declaim (inline all-processes)) (defun all-processes () "Return a list of all the live processes." *all-processes*) (declaim (type (or null process) *initial-process*)) (defvar *initial-process* nil) ;;; Without-scheduling -- Public ;;; ;;; Disable scheduling while the body is executed. Scheduling is ;;; typically inhibited when process state is being modified. ;;; (defvar *inhibit-scheduling* t) ;;; (defmacro without-scheduling (&body body) "Execute the body the scheduling disabled." `(let ((inhibit *inhibit-scheduling*)) (unwind-protect (progn (setf *inhibit-scheduling* t) ,@body) (setf *inhibit-scheduling* inhibit)))) (defmacro atomic-incf (reference &optional (delta 1)) "Increaments the reference by delta in a single atomic operation" `(without-scheduling (incf ,reference ,delta))) (defmacro atomic-decf (reference &optional (delta 1)) "Decrements the reference by delta in a single atomic operation" `(without-scheduling (decf ,reference ,delta))) (defmacro atomic-push (obj place) "Atomically push object onto place." `(without-scheduling (push ,obj ,place))) (defmacro atomic-pop (place) "Atomically pop place." `(without-scheduling (pop ,place))) ;;; If a process other than the initial process throws to the ;;; %end-of-the-world then *quitting-lisp* is set to the exit value, ;;; after which further process creation blocks. If the initial ;;; process is running the idle loop then it will perform the exit ;;; when it runs. ;;; (defvar *quitting-lisp* nil) ;;; Update-Process-Timers -- Internal ;;; ;;; Update the processes times for the current and new process before ;;; a process switch. ;;; (defun update-process-timers (current-process new-process) (declare (type process current-process new-process) (optimize (speed 3) (safety 0))) (let ((real-time (get-real-time))) (incf (process-%real-time current-process) (- real-time (process-scheduled-real-time current-process))) (setf (process-scheduled-real-time current-process) real-time) (setf (process-scheduled-real-time new-process) real-time)) (let ((run-time (get-run-time))) (incf (process-%run-time current-process) (- run-time (process-scheduled-run-time current-process))) (setf (process-scheduled-run-time current-process) run-time) (setf (process-scheduled-run-time new-process) run-time)) (values)) (defun apply-with-bindings (function args bindings) (if bindings (progv (mapcar #'car bindings) (mapcar #'(lambda (binding) (eval (cdr binding))) bindings) (apply function args)) (apply function args))) ;;; Make-Process -- Public ;;; (defun make-process (function &key (name "Anonymous") (run-reasons (list :enable)) (arrest-reasons nil) (initial-bindings nil)) "Make a process which will run FUNCTION when it starts up. By default the process is created in a runnable (active) state. If FUNCTION is NIL, the process is started in a killed state; it may be restarted later with process-preset. :NAME A name for the process displayed in process listings. :RUN-REASONS Initial value for process-run-reasons; defaults to (:ENABLE). A process needs a at least one run reason to be runnable. Together with arrest reasons, run reasons provide an alternative to process-wait for controling whether or not a process is runnable. To get the default behavior of MAKE-PROCESS in Allegro Common Lisp, which is to create a process which is active but not runnable, initialize RUN-REASONS to NIL. :ARREST-REASONS Initial value for process-arrest-reasons; defaults to NIL. A process must have no arrest reasons in order to be runnable. :INITIAL-BINDINGS An alist of initial special bindings for the process. At startup the new process has a fresh set of special bindings with a default binding of *package* setup to the CL-USER package. INITIAL-BINDINGS specifies additional bindings for the process. The cdr of each alist element is evaluated in the fresh dynamic environment and then bound to the car of the element." (declare (type (or null function) function)) (cond (*quitting-lisp* ;; No more processes if about to quit lisp. (process-wait "Quitting Lisp" #'(lambda () nil))) ((null function) ;; If function is nil then create a dead process; can be ;; restarted with process-preset. (%make-process :initial-function nil :name name :state :killed :%run-reasons run-reasons :%arrest-reasons arrest-reasons :initial-bindings initial-bindings)) (t ;; Create a stack-group. (let ((process (%make-process :name name :state :active :initial-function function :%run-reasons run-reasons :%arrest-reasons arrest-reasons :initial-bindings initial-bindings :stack-group (make-stack-group name #'(lambda () (unwind-protect (catch '%end-of-the-process ;; Catch throws to the %end-of-the-world. (setf *quitting-lisp* (catch 'lisp::%end-of-the-world (with-simple-restart (destroy "Destroy the process") (setf *inhibit-scheduling* nil) (setf (process-%return-values *current-process*) (multiple-value-list (apply-with-bindings function nil initial-bindings)))) ;; Normal exit. (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) ;; About to return to the resumer's ;; stack-group, which in this case is the ;; initial process's stack-group. (setf (process-state *current-process*) :killed) (setf *all-processes* (delete *current-process* *all-processes*)) (setf (process-%whostate *current-process*) nil) (setf (process-%run-reasons *current-process*) nil) (setf (process-%arrest-reasons *current-process*) nil) (setf (process-wait-function-args *current-process*) nil) (setf (process-wait-function *current-process*) nil) (setf (process-wait-timeout *current-process*) nil) (setf (process-wait-return-value *current-process*) nil) (setf (process-interrupts *current-process*) nil) (update-process-timers *current-process* *initial-process*) (setf *current-process* *initial-process*))) *initial-stack-group* nil)))) (atomic-push process *all-processes*) process)))) (defun process-run-reasons (process) (process-%run-reasons process)) (defun process-add-run-reason (process object) (atomic-push object (process-%run-reasons process))) (defun process-revoke-run-reason (process object) (let ((run-reasons (without-scheduling (setf (process-%run-reasons process) (delete object (process-%run-reasons process)))))) (when (and (null run-reasons) (eq process mp::*current-process*)) (process-yield)))) (defun process-arrest-reasons (process) (process-%arrest-reasons process)) (defun process-add-arrest-reason (process object) (atomic-push object (process-%arrest-reasons process)) (when (eq process mp::*current-process*) (process-yield))) (defun process-revoke-arrest-reason (process object) (without-scheduling (setf (process-%arrest-reasons process) (delete object (process-%arrest-reasons process))))) ;;; Process-Interrupt -- Public ;;; (defun process-interrupt (process function) "Interrupt process and cause it to evaluate function." ;; Place the interrupt function at the end of process's interrupts ;; queue, to be called the next time the process is scheduled. (without-scheduling (setf (process-interrupts process) (append (list function) (process-interrupts process)))) (process-yield)) ;;; Destroy-Process -- Public ;;; (defun destroy-process (process) "Destroy a process. The process is sent a interrupt which throws to the end of the process allowing it to unwind gracefully." (declare (type process process)) (assert (not (eq process *current-process*))) (without-scheduling (unless (eq (process-state process) :killed) ;; Place a throw to end-of-the-world at the start of process's ;; interrupts queue, to be called the next time the process is ;; scheduled. (push #'(lambda () (throw '%end-of-the-process nil)) (process-interrupts process)) ;; Ensure that the process is active so that it can accept this ;; interrupt. (setf (process-state process) :active (process-%arrest-reasons process) nil) (push :destroyed (process-%run-reasons process)))) ;; Should we wait until it's dead? (process-yield)) (defun restart-process (process) "Restart process by unwinding it to its initial state and calling its initial function." (destroy-process process) (if *inhibit-scheduling* ;Called inside without-scheduling? (assert (eq (process-state process) :killed)) (process-wait "Waiting for process to die" #'(lambda () (eq (process-state process) :killed)))) ;; No more processes if about to quit lisp. (when *quitting-lisp* (process-wait "Quitting Lisp" #'(lambda () nil))) ;; Create a new stack-group. (without-scheduling (setf (process-stack-group process) (make-stack-group (process-name process) #'(lambda () (unwind-protect (catch '%end-of-the-process ;; Catch throws to the %end-of-the-world. (setf *quitting-lisp* (catch 'lisp::%end-of-the-world (with-simple-restart (destroy "Destroy the process") (setf *inhibit-scheduling* nil) (apply-with-bindings (process-initial-function process) (process-initial-args process) (process-initial-bindings process))) ;; Normal exit. (throw '%end-of-the-process nil)))) (setf *inhibit-scheduling* t) ;; About to return to the resumer's stack-group, which ;; in this case is the initial process's stack-group. (setf (process-state *current-process*) :killed) (setf *all-processes* (delete *current-process* *all-processes*)) (setf (process-%whostate *current-process*) nil) (setf (process-%run-reasons *current-process*) nil) (setf (process-%arrest-reasons *current-process*) nil) (setf (process-wait-function-args *current-process*) nil) (setf (process-wait-function *current-process*) nil) (setf (process-wait-timeout *current-process*) nil) (setf (process-wait-return-value *current-process*) nil) (setf (process-interrupts *current-process*) nil) (update-process-timers *current-process* *initial-process*) (setf *current-process* *initial-process*))) *initial-stack-group* nil)) (setf (process-%whostate process) nil) (setf (process-wait-function-args process) nil) (setf (process-wait-function process) nil) (setf (process-wait-timeout process) nil) (setf (process-wait-return-value process) nil) (setf (process-interrupts process) nil) (setf (process-scheduled-real-time process) (get-real-time)) (setf (process-scheduled-run-time process) (get-run-time)) (setf (process-%real-time process) 0d0) (setf (process-%run-time process) 0d0) (setf (process-state process) :active) (push process *all-processes*)) process) ;;; Process-Preset (defun process-preset (process function &rest args) "Restart process, unwinding it to its initial state and calls function with args." (setf (process-initial-function process) function) (setf (process-initial-args process) args) (restart-process process)) ;;; Disable-Process -- Public ;;; (defun disable-process (process) "Disable process from being runnable until enabled." (without-scheduling (assert (not (eq (process-state process) :killed))) (setf (process-state process) :inactive))) ;;; Enable-Process -- Public ;;; (defun enable-process (process) "Allow process to become runnable again after it has been disabled." (without-scheduling (assert (not (eq (process-state process) :killed))) (setf (process-state process) :active))) ;;; Process-Wait -- Public. ;;; (defun process-wait (whostate predicate &rest args) "Causes the process to wait until predicate returns True. Processes can only call process-wait when scheduling is enabled, and the predicate can not call process-wait. Since the predicate may be evaluated may times by the scheduler it should be relative fast native compiled code. The single True predicate value is returned." (assert (not *inhibit-scheduling*)) (assert (not (process-wait-function *current-process*))) ;; Don't need the disable scheduling here because the scheduler ;; doesn't mess with the whostate or timeout until the function is ;; setup, unless the process is interrupted in which case the ;; scheduler restores the state when execution resumers here. (setf (process-%whostate *current-process*) whostate) (setf (process-wait-timeout *current-process*) nil) (setf (process-wait-function-args *current-process*) args) (setf (process-wait-function *current-process*) predicate) (process-yield) (process-wait-return-value *current-process*)) ;;; Process-Wait-With-Timeout -- Public ;;; (defun process-wait-with-timeout (whostate timeout predicate &rest args) (declare (type (or fixnum float) timeout)) "Causes the process to wait until predicate returns True, or the number of seconds specified by timeout has elapsed. The timeout may be a fixnum or a float in seconds. The single True predicate value is returned, or NIL if the timeout was reached." (assert (not *inhibit-scheduling*)) (assert (not (process-wait-function *current-process*))) ;; Don't need the disable scheduling here because the scheduler ;; doesn't mess with the whostate or timeout until the function is ;; setup, unless the process is interrupted in which case the ;; scheduler restores the state when execution resumers here. (setf (process-%whostate *current-process*) whostate) (let ((timeout (etypecase timeout (fixnum (coerce timeout 'double-float)) (single-float (coerce timeout 'double-float)) (double-float (coerce timeout 'double-float))))) (declare (double-float timeout)) (setf (process-wait-timeout *current-process*) (+ timeout (get-real-time))) (setf (process-wait-function-args *current-process*) args) (setf (process-wait-function *current-process*) predicate)) (process-yield) (process-wait-return-value *current-process*)) ;;; The remaining processes in the scheduling queue for this cycle, ;;; the remainder of *all-processes*. The *current-process* is the ;;; first element of this list. (defvar *remaining-processes* nil) ;;; The idle process will only run when there are no other runnable ;;; processes. (defvar *idle-process* nil) ;;; Run-Idle-Process-P -- Internal. ;;; ;;; Decide when to allow the idle process to run. ;;; (defun run-idle-process-p () ;; Check if there are any other runnable processes. (dolist (process *all-processes* t) (when (and (not (eq process *idle-process*)) (process-active-p process) (not (process-wait-function process))) (return nil)))) ;;; Shutdown-multi-processing -- Internal. ;;; (defun shutdown-multi-processing () "Try to gracefully destroy all the processes giving them some chance to unwinding, before shutting down multi-processing. This is currently necessary before a purify and is performed before a save-lisp. Multi-processing can be restarted by calling init-multi-processing." (when *initial-process* (assert (eq *current-process* *initial-process*) () "Only the *initial-process* can shutdown multi-processing") (let ((destroyed-processes nil)) (do ((cnt 0 (1+ cnt))) ((> cnt 10)) (declare (type kernel:index cnt)) (dolist (process *all-processes*) (when (and (not (eq process *current-process*)) (process-active-p process) (not (member process destroyed-processes))) (destroy-process process) (push process destroyed-processes))) (unless (rest *all-processes*) (return)) (format t (intl:ngettext "Destroyed ~d process; remaining ~d~%" "Destroyed ~d processes; remaining ~d~%" (length destroyed-processes)) (length destroyed-processes) (length *all-processes*)) (process-yield))) (start-sigalrm-yield 0 0) ; Off with the interrupts. ;; Reset the multi-processing state. (setf *inhibit-scheduling* t) (setf *initial-process* nil) (setf *idle-process* nil) (setf *current-process* (%make-process :name "Startup" :state :inactive :stack-group nil)) (setf *all-processes* nil) (setf *remaining-processes* nil) ;; Cleanup the stack groups. (setf x86::*control-stacks* (make-array 0 :element-type '(or null (unsigned-byte 32)) :initial-element nil)) (setf *current-stack-group* nil) (setf *initial-stack-group* nil))) ;;; Idle-Process-Loop -- Internal ;;; ;;; A useful idle process loop, waiting on events using the select ;;; based event server, which is assumed to be setup to call ;;; process-yielding periodically. ;;; (declaim (double-float *idle-loop-timeout*)) (defvar *idle-loop-timeout* 0.1d0) ;;; (defun idle-process-loop () "An idle loop to be run by the initial process. The select based event server is called with a timeout calculated from the minimum of the *idle-loop-timeout* and the time to the next process wait timeout. To avoid this delay when there are runnable processes the *idle-process* should be setup to the *initial-process*. If one of the processes quits by throwing to %end-of-the-world then *quitting-lisp* will have been set to the exit value which is noted by the idle loop which tries to exit gracefully destroying all the processes and giving them a chance to unwind." (declare (optimize (speed 3))) (assert (eq *current-process* *initial-process*) () "Only the *initial-process* is intended to run the idle loop") ;; Ensure the *idle-process* is setup. (unless *idle-process* (setf *idle-process* *current-process*)) ;; Adjust the process name. (setf (process-name *current-process*) "Idle Loop") (do () (*quitting-lisp*) ;; Calculate the wait period. (let ((real-time (get-real-time)) (timeout *idle-loop-timeout*)) (declare (double-float timeout)) (dolist (process *all-processes*) (when (process-active-p process) (let ((wait-timeout (process-wait-timeout process))) (when wait-timeout (let ((delta (- wait-timeout real-time))) (when (< delta timeout) (x86::double-float-reg-bias timeout) (setf timeout delta))))))) (when (> timeout 1d-5) (sys:serve-all-events timeout)) (process-yield))) (shutdown-multi-processing) (throw 'lisp::%end-of-the-world *quitting-lisp*)) ;;; Process-Yield -- Public ;;; ;;; The Scheduler. ;;; (defun process-yield () (declare (optimize (speed 3))) "Allow other processes to run." (unless *inhibit-scheduling* ;; Catch any FP exceptions before entering the scheduler. #+x87 (kernel:float-wait) ;; Inhibit recursive entry of the scheduler. (setf *inhibit-scheduling* t) (assert (eq (first *remaining-processes*) *current-process*)) (assert (eq *current-stack-group* (process-stack-group *current-process*))) (loop ;; Rotate the queue. (setf *remaining-processes* (or (rest *remaining-processes*) *all-processes*)) (let ((next (first *remaining-processes*))) ;; Shouldn't see any :killed porcesses here. (assert (process-alive-p next)) (cond ;; New process at the head of the queue? ((eq next *current-process*)) ;; Ignore inactive processes. ((not (process-active-p next))) ;; If the next process has pending interrupts then return to ;; it to execute these. ((process-interrupts next) (update-process-timers *current-process* next) (setf *current-process* next) (stack-group-resume (process-stack-group next))) (t ;; If not waiting then return. (let ((wait-fn (process-wait-function next)) (wait-fn-args (process-wait-function-args next))) (cond ((null wait-fn) ;; Skip the idle process if there are other runnable ;; processes. (when (or (not (eq next *idle-process*)) (run-idle-process-p)) (update-process-timers *current-process* next) (setf *current-process* next) (stack-group-resume (process-stack-group next)))) (t ;; Check the wait function in the current context ;; saving a stack-group switch; although ;; *current-process* is setup. (let ((current-process *current-process*)) (setf *current-process* next) ;; Predicate true? (let ((wait-return-value (apply wait-fn wait-fn-args))) (cond (wait-return-value ;; Flush the wait. (setf (process-wait-return-value next) wait-return-value) (setf (process-wait-timeout next) nil) (setf (process-wait-function next) nil) (setf (process-%whostate next) nil) (update-process-timers current-process next) (stack-group-resume (process-stack-group next))) (t ;; Timeout? (let ((timeout (process-wait-timeout next))) (when (and timeout (> (get-real-time) timeout)) ;; Flush the wait. (setf (process-wait-return-value next) nil) (setf (process-wait-timeout next) nil) (setf (process-wait-function next) nil) (setf (process-%whostate next) nil) (update-process-timers current-process next) (stack-group-resume (process-stack-group next))))))) ;; Restore the *current-process*. (setf *current-process* current-process)))))))) ;; May have just returned, or have cycled the queue. (let ((next (first *remaining-processes*))) ;; Tolerate :killed processes on the *remaining-processes* list ;; saving their deletion from this list when killed; will be ;; corrected when it cycles back to *all-processes*. (when (and (process-active-p next) ;; Current process at the head of the queue? (eq next *current-process*)) ;; Run any pending interrupts. (let ((interrupt (pop (process-interrupts next)))) (declare (type (or null function) interrupt)) (cond (interrupt ;; Save and reset any wait reasons so that the ;; interrupt can wait. The return-value is also ;; saved and restored in case a process is ;; interrupted before it is read. (let ((wait-function (process-wait-function next)) (wait-timeout (process-wait-timeout next)) (whostate (process-%whostate next)) (wait-return-value (process-wait-return-value next))) (setf (process-wait-function next) nil) (setf (process-wait-timeout next) nil) (setf (process-%whostate next) nil) (setf (process-wait-return-value next) nil) ;; Allow recursive scheduling during the interrupt ;; processing. Only one interrupt is processed on ;; each scheduler queue cycle. The process doesn't ;; return until there are no interrupts. (setf *inhibit-scheduling* nil) (funcall interrupt) (setf *inhibit-scheduling* t) ;; Restore any wait reasons. (setf (process-wait-function next) wait-function) (setf (process-wait-timeout next) wait-timeout) (setf (process-%whostate next) whostate) (setf (process-wait-return-value next) wait-return-value))) (t ;; Check the wait function. (let ((wait-fn (process-wait-function next))) (cond ((null wait-fn) (when (or (not (eq next *idle-process*)) (run-idle-process-p)) (return))) (t ;; Predicate true? (let ((return-value (funcall wait-fn))) (when return-value ;; Flush the wait. (setf (process-wait-return-value next) return-value) (setf (process-wait-timeout next) nil) (setf (process-wait-function next) nil) (setf (process-%whostate next) nil) (return))) ;; Timeout? (let ((timeout (process-wait-timeout next))) (when (and timeout (> (get-real-time) timeout)) ;; Flush the wait. (setf (process-wait-return-value next) nil) (setf (process-wait-timeout next) nil) (setf (process-wait-function next) nil) (setf (process-%whostate next) nil) (return)))))))))))) (setf *inhibit-scheduling* nil))) ;;; Process-Real-Time ;;; ;;; The real time in seconds accrued while the process was scheduled. ;;; (defun process-real-time (process) "Return the accrued real time elapsed while the given process was scheduled. The returned time is a double-float in seconds." (declare (type process process)) (if (eq process *current-process*) (without-scheduling (let ((real-time (get-real-time))) (+ (process-%real-time process) (- real-time (process-scheduled-real-time process))))) (process-%real-time process))) ;;; Process-Run-Time -- Public ;;; ;;; The run time in seconds accrued while the process was scheduled. ;;; (defun process-run-time (process) "Return the accrued run time elapsed for the given process. The returned time is a double-float in seconds." (declare (type process process)) (if (eq process *current-process*) (without-scheduling (let ((run-time (get-run-time))) (+ (process-%run-time process) (- run-time (process-scheduled-run-time process))))) (process-%run-time process))) ;;; Process-Idle-Time -- Public ;;; ;;; The real time in seconds elapsed since the process was last ;;; de-scheduled. ;;; (defun process-idle-time (process) "Return the real time elapsed since the given process was last descheduled. The returned time is a double-float in seconds." (declare (type process process)) (if (eq process *current-process*) 0 (without-scheduling (let ((real-time (get-real-time))) (- real-time (process-scheduled-real-time process)))))) ;;; Start-Sigalrm-Yield -- Internal ;;; ;;; Start a regular interrupt to switch processes. This may not be a ;;; good idea yet as the CMUCL code is not too interrupt safe. ;;; (defun start-sigalrm-yield (&optional (sec 0) (usec 500000)) "Start a regular SIGALRM interrupt which calls process-yield. An optional time in seconds and micro seconds may be provided. Note that CMUCL code base is not too interrupt safe so this may cause problems." (declare (fixnum sec usec)) ;; Disable the gencgc pointer filter to improve interrupt safety. #+(and gencgc nil) (setf (alien:extern-alien "enable_pointer_filter" alien:unsigned) 0) (flet ((sigalrm-handler (signal code scp) (declare (ignore signal code scp)) (cond ((<= lisp::*free-interrupt-context-index* 1) #+nil (format t ".~%") (process-yield)) (t #+nil (format t "-~%"))))) (sys:enable-interrupt :sigalrm #'sigalrm-handler)) (unix:unix-setitimer :real sec usec 0 1) (values)) ;;; Init-Multi-Processing -- Internal. ;;; ;;; Startup multi-processing, initialising the initial process. This ;;; must be called before use of the other multi-process functions. ;;; (defun init-multi-processing () (unless *initial-process* (init-stack-groups) (setf *initial-process* (%make-process :name "Initial" :state :active :%run-reasons (list :enable) :stack-group *initial-stack-group*)) (setf *current-process* *initial-process*) (setf *all-processes* (list *initial-process*)) (setf *remaining-processes* *all-processes*) ;; #+nil (start-sigalrm-yield) (setf *inhibit-scheduling* nil))) (pushnew 'init-multi-processing ext:*after-save-initializations*) ;;; Scrub-all-processes-stacks -- Internal ;;; ;;; Scrub the stored stacks of all the processes. ;;; (defun scrub-all-processes-stacks () (sys:without-interrupts (dolist (process *all-processes*) (let ((stack-group (process-stack-group process))) (when stack-group (scrub-stack-group-stacks stack-group)))))) ;;; (pushnew 'scrub-all-processes-stacks ext:*before-gc-hooks*) ;;; Process-Wait-Until-FD-Usable -- Public. ;;; ;;; Wait until FD is usable for DIRECTION. ;;; (defun process-wait-until-fd-usable (fd direction &optional timeout) "Wait until FD is usable for DIRECTION and return True. DIRECTION should be either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving up and returing NIL." (declare (type kernel:index fd) (type (or real null) timeout) (optimize (speed 3))) (if (or (eq *current-process* *initial-process*) ;; Can't call process-wait if the scheduling is inhibited. *inhibit-scheduling*) ;; The initial-process calls the event server to block. (sys:wait-until-fd-usable fd direction timeout) ;; Other processes use process-wait. (flet ((fd-usable-for-input () (declare (optimize (speed 3) (safety 1))) (alien:with-alien ((read-fds (alien:struct unix:fd-set))) (unix:fd-zero read-fds) (unix:fd-set fd read-fds) (multiple-value-bind (value err) (unix:unix-fast-select (1+ fd) (alien:addr read-fds) nil nil 0 0) ;; Return true when input is available or there is ;; an error other than an interrupt. (and (not (eql value 0)) (or value (not (eql err unix:eintr))))))) (fd-usable-for-output () (declare (optimize (speed 3) (safety 1))) (alien:with-alien ((write-fds (alien:struct unix:fd-set))) (unix:fd-zero write-fds) (unix:fd-set fd write-fds) (multiple-value-bind (value err) (unix:unix-fast-select (1+ fd) nil (alien:addr write-fds) nil 0 0) ;; Return true when ready for output or there is an ;; error other than an interrupt. (and (not (eql value 0)) (or value (not (eql err unix:eintr)))))))) (ecase direction (:input (or (fd-usable-for-input) ;; Wait until input possible. (sys:with-fd-handler (fd :input #'(lambda (fd) (declare (ignore fd) (optimize (speed 3) (safety 0))) (mp:process-yield))) (if timeout (mp:process-wait-with-timeout "Input Wait" timeout #'fd-usable-for-input) (mp:process-wait "Input Wait" #'fd-usable-for-input))))) (:output (or (fd-usable-for-output) ;; Wait until output possible. (sys:with-fd-handler (fd :output #'(lambda (fd) (declare (ignore fd) (optimize (speed 3) (safety 0))) (mp:process-yield))) (if timeout (mp:process-wait-with-timeout "Output Wait" timeout #'fd-usable-for-output) (mp:process-wait "Output Wait" #'fd-usable-for-output))))))))) ;;; Sleep -- Public ;;; ;;; Redefine the sleep function to call process-wait-with-timeout, ;;; rather than blocking. ;;; (defun sleep (n) "This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number." (when (or (not (realp n)) (minusp n)) (error "Invalid argument to SLEEP: ~S.~%~ Must be a non-negative, non-complex number." n)) (cond ((or (eq *current-process* *initial-process*) ;; Can't call process-wait if the scheduling is inhibited. *inhibit-scheduling*) ;; The initial-process may block. (multiple-value-bind (sec usec) (if (integerp n) (values n 0) (multiple-value-bind (sec frac)(truncate n) (values sec (truncate frac 1e-6)))) (unix:unix-select 0 0 0 0 sec usec)) nil) (t (process-wait-with-timeout "Sleep" n (constantly nil))))) ;;; With-Timeout-Internal -- Internal ;;; (defun with-timeout-internal (timeout function timeout-function) (catch 'timer-interrupt (let* ((current-process mp:*current-process*) (timer-process (mp:make-process #'(lambda () (sleep timeout) (mp:process-interrupt current-process #'(lambda () (throw 'timer-interrupt nil)))) :name "Timeout timer"))) (unwind-protect (return-from with-timeout-internal (funcall function)) (mp:destroy-process timer-process)))) (funcall timeout-function)) ;;; With-Timeout -- Public ;;; (defmacro with-timeout ((timeout &body timeout-forms) &body body) "Executes body and returns the values of the last form in body. However, if the execution takes longer than timeout seconds, abort it and evaluate timeout-forms, returning the values of last form." `(flet ((fn () . ,body) (tf () . ,timeout-forms)) (with-timeout-internal ,timeout #'fn #'tf))) ;;; Show-Processes -- Public ;;; (defun show-processes (&optional verbose) "Show the all the processes, their whostate, and state. If the optional verbose argument is true then the run, real, and idle times are also shown." (fresh-line) (dolist (process *all-processes*) (when (eq process *current-process*) (format t "-> ")) (format t "~s ~s ~a~%" process (process-whostate process) (process-state process)) (when verbose (format t "~4TRun time: ~,3f; Real time: ~,3f; Idle time: ~,3f~%" (process-run-time process) (process-real-time process) (process-idle-time process))))) ;;; Top-Level -- Internal ;;; (defun top-level () "Top-level READ-EVAL-PRINT loop for processes." (let ((* nil) (** nil) (*** nil) (- nil) (+ nil) (++ nil) (+++ nil) (/// nil) (// nil) (/ nil) (magic-eof-cookie (cons :eof nil))) (loop (with-simple-restart (abort "Return to Top-Level.") (catch 'lisp::top-level-catcher (unix:unix-sigsetmask 0) (let ((lisp::*in-top-level-catcher* t)) (loop (sys:scrub-control-stack) (fresh-line) (princ (if (functionp ext:*prompt*) (funcall ext:*prompt*) ext:*prompt*)) (force-output) (let ((form (read *standard-input* nil magic-eof-cookie))) (cond ((not (eq form magic-eof-cookie)) (let ((results (multiple-value-list (ext:interactive-eval form)))) (dolist (result results) (fresh-line) (prin1 result)))) (t (throw '%end-of-the-process nil))))))))))) ;;; Startup-Idle-and-Top-Level-Loops -- Internal ;;; (defun startup-idle-and-top-level-loops () "Enter the idle loop, starting a new process to run the top level loop. The awaking of sleeping processes is timed better with the idle loop process running, and starting a new process for the top level loop supports a simultaneous interactive session. Such an initialisation will likely be the default when there is better MP debug support etc." (assert (eq *current-process* *initial-process*) () "Only the *initial-process* is intended to run the idle loop") (init-multi-processing) ; Initialise in case MP had been shutdown. ;; Start a new Top Level loop. (make-process #'top-level :name "Top Level Loop") ;; Enter the idle loop. (idle-process-loop)) ;;; Start-Lisp-Connection-Listener ;;; ;;; Create a process to listen for connections on a TCP port and start ;;; a new top-level process for each connection. ;;; (defun start-lisp-connection-listener (&key (port 1025) (password (random (expt 2 24)))) (declare (type (unsigned-byte 16) port)) "Create a Lisp connection listener, listening on a TCP port for new connections and starting a new top-level loop for each. If a password is not given then one will be generated and reported. A search is performed for the first free port starting at the given port which defaults to 1025." (labels (;; The session top level read eval. loop. (start-top-level (fd) (let ((stream (sys:make-fd-stream fd :input t :output t))) (unwind-protect (let* ((*terminal-io* stream) (*standard-input* (make-synonym-stream '*terminal-io*)) (*standard-output* *standard-input*) (*error-output* *standard-input*) (*debug-io* *standard-input*) (*query-io* *standard-input*) (*trace-output* *standard-input*)) ;; (format t "Enter password: ") (finish-output) (let* ((*read-eval* nil) (read-password (handler-case (read) (error () (return-from start-top-level))))) (unless (equal read-password password) (return-from start-top-level))) (ext:print-herald) ;; (top-level)) (handler-case (close stream) (error ()))))) ;; ;; Turn internet address into string format (ip-address-string (address) (format nil "~D.~D.~D.~D" (ldb (byte 8 24) address) (ldb (byte 8 16) address) (ldb (byte 8 8) address) (ldb (byte 8 0) address))) ;; ;; The body of the connection listener. (listener () (declare (optimize (speed 3))) (let ((fd nil)) (unwind-protect (progn ;; Start the listener. (do () (fd) (handler-case (setf fd (ext:create-inet-listener port)) (error () (incf port)))) (setf (process-name *current-process*) (format nil "Lisp connection listener on port ~d" port)) (format t "~&;;; Started lisp connection listener on ~ port ~d with password ~d~%" port password) (loop ;; Wait for new connections. (process-wait-until-fd-usable fd :input) (multiple-value-bind (new-fd remote-host) (ext:accept-tcp-connection fd) (let ((host-entry (ext:lookup-host-entry remote-host))) (make-process #'(lambda () (start-top-level new-fd)) :name (format nil "Lisp session from ~A" (if host-entry (ext:host-entry-name host-entry) (ip-address-string remote-host)))))))) ;; Close the listener stream. (when fd (unix:unix-close fd)))))) ;; Make the listening thread. (make-process #'listener))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Simple Locking. ;;; (defstruct (lock (:constructor nil) (:print-function %print-lock)) (name nil :type (or null simple-base-string)) (process nil :type (or null process))) (defstruct (recursive-lock (:include lock) (:constructor make-recursive-lock (&optional name)))) (defstruct (error-check-lock (:include lock) (:constructor make-error-check-lock (&optional name)))) (defun make-lock (&optional name &key (kind :recursive)) (ecase kind (:recursive (make-recursive-lock name)) (:error-check (make-error-check-lock name)))) (defun %print-lock (lock stream depth) (declare (type lock lock) (stream stream) (ignore depth)) (print-unreadable-object (lock stream :identity t) (write-string (etypecase lock (recursive-lock "Recursive-lock") (error-check-lock "Error-Check-lock")) stream) (let ((name (lock-name lock))) (when name (format stream " ~a" name))) (let ((process (lock-process lock))) (cond (process (format stream ", held by ~s" process)) (t (write-string ", free" stream)))))) ;;; Lock-Wait -- Internal ;;; ;;; Wait for the lock to be free and acquire it for the ;;; *current-process*. ;;; (defun lock-wait (lock whostate) (declare (type lock lock)) (process-wait whostate #'(lambda () (declare (optimize (speed 3))) #-x86 (unless (lock-process lock) (setf (lock-process lock) *current-process*)) #+x86 (null (kernel:%instance-set-conditional lock 2 nil *current-process*))))) ;;; Lock-Wait-With-Timeout -- Internal ;;; ;;; Wait with a timeout for the lock to be free and acquire it for the ;;; *current-process*. ;;; (defun lock-wait-with-timeout (lock whostate timeout) (declare (type lock lock)) (process-wait-with-timeout whostate timeout #'(lambda () (declare (optimize (speed 3))) #-x86 (unless (lock-process lock) (setf (lock-process lock) *current-process*)) #+x86 (null (kernel:%instance-set-conditional lock 2 nil *current-process*))))) ;;; Seize-lock -- Internal ;;; ;;; Atomically seize a lock if it's free. ;;; #-x86 (defun seize-lock (lock) (declare (type lock lock) (optimize (speed 3))) (sys:without-interrupts (unless (lock-process lock) (setf (lock-process lock) *current-process*)))) ;;; With-Lock-Held -- Public ;;; (defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key (wait t) timeout) &body body) "Execute the body with the lock held. If the lock is held by another process then the current process waits until the lock is released or an optional timeout is reached. The optional wait timeout is a time in seconds acceptable to process-wait-with-timeout. The results of the body are return upon success and NIL is return if the timeout is reached. When the wait key is NIL and the lock is held by another process then NIL is return immediately without processing the body." (let ((have-lock (gensym))) `(let ((,have-lock (eq (lock-process ,lock) *current-process*))) (unwind-protect ,(cond ((and timeout wait) `(progn (when (and (error-check-lock-p ,lock) ,have-lock) (error "Dead lock")) (when (or ,have-lock #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) #-x86 (seize-lock ,lock) (if ,timeout (lock-wait-with-timeout ,lock ,whostate ,timeout) (lock-wait ,lock ,whostate))) ,@body))) (wait `(progn (when (and (error-check-lock-p ,lock) ,have-lock) (error "Dead lock")) (unless (or ,have-lock #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) #-x86 (seize-lock ,lock)) (lock-wait ,lock ,whostate)) ,@body)) (t `(when (or (and (recursive-lock-p ,lock) ,have-lock) #+x86 (null (kernel:%instance-set-conditional ,lock 2 nil *current-process*)) #-x86 (seize-lock ,lock)) ,@body))) (unless ,have-lock #+x86 (kernel:%instance-set-conditional ,lock 2 *current-process* nil) #-x86 (when (eq (lock-process ,lock) *current-process*) (setf (lock-process ,lock) nil))))))) (defun process-join (process) (mp:process-wait (format nil "Waiting for thread ~A to complete" process) (lambda () (not (mp:process-alive-p process)))) (values-list (process-%return-values process))) cmucl-21a/src/code/ntrace.lisp000066400000000000000000000723161260377556400164400ustar00rootroot00000000000000;;; -*- Package: debug -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/ntrace.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This is a tracing facility based on breakpoints. ;;; ;;; Written by Rob MacLachlan and Bill Chiles. ;;; ;;; ********************************************************************** ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(trace untrace)) (in-package "DEBUG") (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default* *trace-encapsulate-package-names*)) (use-package :fwrappers) (defvar *trace-values* nil "This is bound to the returned values when evaluating :BREAK-AFTER and :PRINT-AFTER forms.") (defvar *max-trace-indentation* 40 "If the trace indentation exceeds this value, then indentation restarts at 0.") (defvar *trace-encapsulate-default* :default "The default value for the :ENCAPSULATE option to trace.") (defvar *trace-encapsulate-package-names* '("LISP" "COMMON-LISP" "CONDITIONS" "DEBUG" "EXTENSIONS" "FORMAT" "KERNEL" "LOOP" "PRETTY-PRINT" "SYSTEM" "COMPILER" "TRACE") "List of package names. Encapsulate functions from these packages by default. This should at least include the packages of functions used by TRACE, directly or indirectly.") ;;;; Internal state: ;;; A hash-table that maps each traced function to the TRACE-INFO. The entry ;;; for a closure is the shared function-entry object. ;;; (defvar *traced-functions* (make-hash-table :test #'equal)) ;;; The TRACE-INFO structure represents all the information we need to trace a ;;; given function. ;;; (defstruct (trace-info (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream) (format stream "Trace-Info ~S" (trace-info-what s))))) (:make-load-form-fun :just-dump-it-normally)) ;; ;; The original representation of the thing traced. (what nil :type (or function cons symbol)) ;; ;; True if What is a function name whose definition we should track. (named nil) ;; ;; True if tracing is to be done by encapsulation rather than breakpoints. ;; T implies Named. (encapsulated *trace-encapsulate-default*) ;; ;; True if this trace has been untraced. (untraced nil) ;; ;; Breakpoints we set up to trigger tracing. (start-breakpoint nil :type (or di:breakpoint null)) (end-breakpoint nil :type (or di:breakpoint null)) ;; ;; The list of function names for wherein. NIL means unspecified. (wherein nil :type list) ;; ;; Like wherein, but only if the caller is in the list. (wherein-only nil :type list) ;; ;; The following slots represent the forms that we are supposed to evaluate ;; on each iteration. Each form is represented by a cons (Form . Function), ;; where the Function is the cached result of coercing Form to a function. ;; Forms which use the current environment are converted with ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function. ;; Null environment forms also have one-arg functions, but the argument is ;; ignored. NIL means unspecified (the default.) ;; ;; Current environment forms: (condition nil) (break nil) ;; ;; List of current environment forms: (print () :type list) ;; ;; Null environment forms. (condition-after nil) (break-after nil) ;; ;; List of null environment forms (print-after () :type list)) ;;; This is a list of conses (function-end-cookie . condition-satisfied), ;;; which we use to note distinct dynamic entries into functions. When we ;;; enter a traced function, we add a entry to this list holding the new ;;; end-cookie and whether the trace condition was statisfied. We must save ;;; the trace condition so that the after breakpoint knows whether to print. ;;; The length of this list tells us the indentation to use for printing TRACE ;;; messages. ;;; ;;; This list also helps us synchronize the TRACE facility dynamically for ;;; detecting non-local flow of control. Whenever execution hits a ;;; :function-end breakpoint used for TRACE'ing, we look for the ;;; function-end-cookie at the top of *traced-entries*. If it is not there, we ;;; discard any entries that come before our cookie. ;;; ;;; When we trace using encapsulation, we bind this variable and add ;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated ;;; tracing. ;;; (defvar *traced-entries* ()) (declaim (list *traced-entries*)) ;;; This variable is used to discourage infinite recursions when some trace ;;; action invokes a function that is itself traced. In this case, we quietly ;;; ignore the inner tracing. ;;; (defvar *in-trace* nil) ;;;; Utilities: ;;; TRACE-FDEFINITION -- Internal ;;; ;;; Given a function name, a function or a macro name, return the raw ;;; definition and some information. "Raw" means that if the result is a ;;; closure, we strip off the closure and return the bare code. The second ;;; value is T if the argument was a function name. The third value is one of ;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and ;;; :FUNCALLABLE-INSTANCE. ;;; (defun trace-fdefinition (x) (multiple-value-bind (res named-p local) (typecase x (symbol (cond ((special-operator-p x) (error (intl:gettext "Can't trace special form ~S.") x)) ((macro-function x)) (t (values (fdefinition x) t)))) (function x) ((cons (member flet labels)) ;; An extended function name for flet/labels functions. (values (fdefinition (car (last x))) t x)) (t (values (fdefinition x) t))) (if (eval:interpreted-function-p res) (values res named-p (if (eval:interpreted-function-closure res) :interpreted-closure :interpreted)) (case (kernel:get-type res) (#.vm:closure-header-type (values (kernel:%closure-function res) named-p :compiled-closure)) (#.vm:funcallable-instance-header-type (values res named-p :funcallable-instance)) (t (values res named-p :compiled local)))))) ;;; TRACE-REDEFINED-UPDATE -- Internal ;;; ;;; When a function name is redefined, and we were tracing that name, then ;;; untrace the old definition and trace the new one. ;;; (defun trace-redefined-update (fname new-value) (when (fboundp fname) (multiple-value-bind (fun named kind local) (trace-fdefinition fname) (let* ((fkey (or local fun)) (info (gethash fkey *traced-functions*))) (flet ((handle-local-funs () ;; FIXME: This is gross. We need to grovel over the ;; *traced-functions* to see if any flet/labels functions ;; have been traced in the function we're redefining. (maphash #'(lambda (key info) (when (and (listp key) (eq fname (car (last key)))) (when info (untrace-1 key) (trace-1 key info new-value)))) *traced-functions*))) (when (and info (trace-info-named info)) (untrace-1 fname) (trace-1 fname info new-value)) (handle-local-funs)))))) ;;; (push #'trace-redefined-update ext:*setf-fdefinition-hook*) ;;; COERCE-FORM, COERCE-FORM-LIST -- Internal ;;; ;;; Annotate some forms to evaluate with pre-converted functions. Each form ;;; is really a cons (exp . function). Loc is the code location to use for ;;; the lexical environment. If Loc is NIL, evaluate in the null environment. ;;; If Form is NIL, just return NIL. ;;; (defun coerce-form (form loc) (when form (let ((exp (car form))) (if (di:code-location-p loc) (let ((fun (di:preprocess-for-eval exp loc))) (cons exp #'(lambda (frame) (let ((*current-frame* frame)) (funcall fun frame))))) (let* ((bod (ecase loc ((nil) exp) (:encapsulated `(flet ((debug:arg (n) (declare (special argument-list)) (elt argument-list n))) (declare (ignorable #'debug:arg)) ,exp)))) (fun (coerce `(lambda () ,bod) 'function))) (cons exp #'(lambda (frame) (declare (ignore frame)) (let ((*current-frame* nil)) (funcall fun))))))))) ;;; (defun coerce-form-list (forms loc) (mapcar #'(lambda (x) (coerce-form x loc)) forms)) ;;; PRINT-TRACE-INDENTATION -- Internal ;;; ;;; Print indentation according to the number of trace entries. Entries ;;; whose condition was false don't count. ;;; (defun print-trace-indentation () (let ((depth 0)) (dolist (entry *traced-entries*) (when (cdr entry) (incf depth))) (format t "~@V,0T~D: " (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2) depth))) ;;; TRACE-WHEREIN-P -- Internal. ;;; ;;; Return true if one of the Names appears on the stack below Frame. ;;; (defun trace-wherein-p (frame names) (do ((frame (di:frame-down frame) (di:frame-down frame))) ((not frame) nil) (let ((frame-name (di:debug-function-name (di:frame-debug-function frame)))) (when (member frame-name names :test #'equal) (return t))))) ;;; TRACE-WHEREIN-ONLY-P -- Internal ;;; ;;; Like, TRACE-WHEREIN-ONLY-P, except true only if the last stack ;;; frame Frame has the given name. (defun trace-wherein-only-p (frame name) (let ((caller-frame (di::frame-down frame))) (when caller-frame (let ((frame-name (di:debug-function-name (di:frame-debug-function caller-frame)))) (member frame-name name :test #'equal))))) ;;; TRACE-PRINT -- Internal ;;; ;;; Handle print and print-after options. ;;; (defun trace-print (frame forms) (dolist (ele forms) (fresh-line) (print-trace-indentation) (format t "~S = ~S" (car ele) (funcall (cdr ele) frame)))) ;;; TRACE-MAYBE-BREAK -- Internal ;;; ;;; Test a break option, and break if true. ;;; (defun trace-maybe-break (info break where frame) (when (and break (funcall (cdr break) frame)) (di:flush-frames-above frame) (let ((*stack-top-hint* frame)) (break (intl:gettext "Breaking ~A traced call to ~S:") where (trace-info-what info))))) ;;; DISCARD-INVALID-ENTRIES -- Internal ;;; ;;; This function discards any invalid cookies on our simulated stack. ;;; Encapsulated entries are always valid, since we bind *traced-entries* in ;;; the encapsulation. ;;; (defun discard-invalid-entries (frame) (loop (when (or (null *traced-entries*) (let ((cookie (caar *traced-entries*))) (or (not cookie) (di:function-end-cookie-valid-p frame cookie)))) (return)) (pop *traced-entries*))) ;;;; Hook functions: ;;; TRACE-START-BREAKPOINT-FUN -- Internal. ;;; ;;; Return a closure that can be used for a function start breakpoint hook ;;; function and a closure that can be used as the FUNCTION-END-COOKIE ;;; function. The first communicates the sense of the Condition to the second ;;; via a closure variable. ;;; (defun trace-start-breakpoint-fun (info) (let (conditionp) (values #'(lambda (frame bpt) (declare (ignore bpt)) (discard-invalid-entries frame) (let ((condition (trace-info-condition info)) (wherein (trace-info-wherein info)) (wherein-only (trace-info-wherein-only info))) (setq conditionp (and (not *in-trace*) (or (not condition) (funcall (cdr condition) frame)) (or (not wherein) (trace-wherein-p frame wherein)) (or (not wherein-only) (trace-wherein-only-p frame wherein-only))))) (when conditionp (let ((*print-length* (or *debug-print-length* *print-length*)) (*print-level* (or *debug-print-level* *print-level*)) (kernel:*current-level* 0) (*standard-output* *trace-output*) (*in-trace* t)) (fresh-line) (print-trace-indentation) (if (trace-info-encapsulated info) (locally (declare (special basic-definition argument-list)) (prin1 `(,(trace-info-what info) ,@argument-list))) (print-frame-call frame :verbosity 1)) (terpri) (trace-print frame (trace-info-print info))) (trace-maybe-break info (trace-info-break info) "before" frame))) #'(lambda (frame cookie) (declare (ignore frame)) (push (cons cookie conditionp) *traced-entries*))))) ;;; TRACE-END-BREAKPOINT-FUN -- Internal ;;; ;;; This prints a representation of the return values delivered. First, ;;; this checks to see that cookie is at the top of *traced-entries*; if it is ;;; not, then we need to adjust this list to determine the correct indentation ;;; for output. We then check to see if the function is still traced and that ;;; the condition succeeded before printing anything. ;;; (defun trace-end-breakpoint-fun (info) #'(lambda (frame bpt *trace-values* cookie) (declare (ignore bpt)) (unless (eq cookie (caar *traced-entries*)) (setf *traced-entries* (member cookie *traced-entries* :key #'car))) (let ((entry (pop *traced-entries*))) (when (and (not (trace-info-untraced info)) (or (cdr entry) (let ((cond (trace-info-condition-after info))) (and cond (funcall (cdr cond) frame))))) (let ((*print-length* (or *debug-print-length* *print-length*)) (*print-level* (or *debug-print-level* *print-level*)) (kernel:*current-level* 0) (*standard-output* *trace-output*) (*in-trace* t)) (fresh-line) (pprint-logical-block (*standard-output* nil) (print-trace-indentation) (pprint-indent :current 2) (format t (intl:gettext "~S returned") (trace-info-what info)) (dolist (v *trace-values*) (write-char #\space) (pprint-newline :linear) (prin1 v))) (terpri) (trace-print frame (trace-info-print-after info))) (trace-maybe-break info (trace-info-break-after info) "after" frame))))) ;;; TRACE-FWRAPPER -- Internal ;;; ;;; This function is called by the trace encapsulation. It calls the ;;; breakpoint hook functions with NIL for the breakpoint and cookie, which ;;; we have cleverly contrived to work for our hook functions. ;;; (define-fwrapper trace-fwrapper (&rest args) (let* ((info (fwrapper-user-data fwrapper)) (name (trace-info-what info)) (fdefn (lisp::fdefinition-object name nil)) (basic-definition (fwrapper-next fwrapper)) (argument-list args)) (declare (special basic-definition argument-list)) (letf (((lisp::fdefn-function fdefn) basic-definition)) (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info) (let ((frame (di:frame-down (di:top-frame)))) (funcall start frame nil) (let ((*traced-entries* *traced-entries*)) (funcall cookie frame nil) (let ((vals (multiple-value-list (call-next-function)))) (funcall (trace-end-breakpoint-fun info) frame nil vals nil) (values-list vals)))))))) ;;; TRACE-1 -- Internal. ;;; ;;; Trace one function according to the specified options. We copy the ;;; trace info (it was a quoted constant), fill in the functions, and then ;;; install the breakpoints or encapsulation. ;;; ;;; If non-null, Definition is the new definition of a function that we are ;;; automatically retracing; this ;;; (defun trace-1 (function-or-name info &optional definition) (multiple-value-bind (fun named kind local) (if definition ;; Tracing a new definition. If function-or-name looks like a ;; local function, we trace the new definition with the local ;; function. Otherwise, we do what we used to do. (if (and (valid-function-name-p function-or-name) (typep function-or-name '(cons (member flet labels)))) (multiple-value-bind (fun named kind) (trace-fdefinition definition) (values fun t kind function-or-name)) (values definition t (nth-value 2 (trace-fdefinition definition)))) (trace-fdefinition function-or-name)) (when (gethash (or local fun) *traced-functions*) (warn (intl:gettext "Function ~S already TRACE'd, retracing it.") function-or-name) (untrace-1 fun)) (let* ((debug-fun (di:function-debug-function fun :local-name local)) (encapsulated (if (eq (trace-info-encapsulated info) :default) (let ((encapsulate-p (or (not (di::can-set-function-end-breakpoint-p debug-fun)) (encapsulate-by-package-p function-or-name)))) (ecase kind (:compiled encapsulate-p) (:compiled-closure (unless (functionp function-or-name) (warn (intl:gettext "Tracing shared code for ~S:~% ~S") function-or-name fun)) encapsulate-p) ((:interpreted :interpreted-closure :funcallable-instance) t))) (trace-info-encapsulated info))) (loc (if encapsulated :encapsulated (di:debug-function-start-location debug-fun))) (info (make-trace-info :what function-or-name :named named :encapsulated encapsulated :wherein (trace-info-wherein info) :wherein-only (trace-info-wherein-only info) :condition (coerce-form (trace-info-condition info) loc) :break (coerce-form (trace-info-break info) loc) :print (coerce-form-list (trace-info-print info) loc) :break-after (coerce-form (trace-info-break-after info) nil) :condition-after (coerce-form (trace-info-condition-after info) nil) :print-after (coerce-form-list (trace-info-print-after info) nil)))) (flet ((verify-wherein (wherein-info type) (dolist (wherein wherein-info) (multiple-value-bind (validp block-name) (ext:valid-function-name-p wherein) (declare (ignore validp)) (unless (or (stringp block-name) (fboundp block-name)) (warn (intl:gettext "~S name is not a defined global function: ~S") type wherein)))))) (verify-wherein (trace-info-wherein info) :wherein) (verify-wherein (trace-info-wherein-only info) :wherein-only)) (cond (encapsulated (unless named (error (intl:gettext "Can't use encapsulation to trace anonymous function ~S.") fun)) (when (and (listp function-or-name) (member function-or-name '(flet labels))) (error (intl:gettext "Can't use encapsulation to trace local flet/labels function ~S.") function-or-name)) (fwrap function-or-name #'trace-fwrapper :type 'trace :user-data info)) (t (multiple-value-bind (start-fun cookie-fun) (trace-start-breakpoint-fun info) (let ((start (di:make-breakpoint start-fun debug-fun :kind :function-start)) (end (di:make-breakpoint (trace-end-breakpoint-fun info) debug-fun :kind :function-end :function-end-cookie cookie-fun))) (setf (trace-info-start-breakpoint info) start) (setf (trace-info-end-breakpoint info) end) ;; ;; The next two forms must be in the order in which they appear, ;; since the start breakpoint must run before the function-end ;; breakpoint's start helper (which calls the cookie function.) ;; One reason is that cookie function requires that the CONDITIONP ;; shared closure variable be initialized. (di:activate-breakpoint start) (di:activate-breakpoint end))))) (setf (gethash (or local fun) *traced-functions*) info))) function-or-name) ;;; ;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE ;;; should use encapsulation instead of function-end breakpoints. ;;; (defun encapsulate-by-package-p (function-or-name) (multiple-value-bind (valid block) (valid-function-name-p function-or-name) (when (and valid (symbolp block)) (let* ((pkg (symbol-package block)) (pkg-name (and pkg (package-name pkg)))) (member pkg-name *trace-encapsulate-package-names* :test #'equal))))) ;;;; The TRACE macro: ;;; PARSE-TRACE-OPTIONS -- Internal ;;; ;;; Parse leading trace options off of Specs, modifying Info accordingly. ;;; The remaining portion of the list is returned when we encounter a plausible ;;; function name. ;;; (defun parse-trace-options (specs info) (let ((current specs)) (flet ((collect-names (value) (collect ((new-names)) (dolist (name (if (listp (car value)) (car value) value)) (cond ((and (consp name) (eq (car name) 'method) (ext:valid-function-name-p name)) ;; This needs to be coordinated with how the ;; debugger prints method names. So this is ;; what this code does. Any method qualifiers ;; appear as a list in the debugger. No ;; qualifiers show up as NIL. We also take the ;; method and add a pcl::fast-method in case the ;; method wasn't compiled. (Do we need to do this?) (let ((method (cond ((atom (third name)) `(,(second name) (,(third name)) ,@(cdddr name))) (t `(,(second name) nil ,@(cddr name)))))) (new-names `(pcl::fast-method ,@method)) (new-names `(method ,@method)))) (t (new-names name)))) (new-names)))) (loop (when (endp current) (return)) (let ((option (first current)) (value (cons (second current) nil))) (case option (:condition (setf (trace-info-condition info) value)) (:condition-after (setf (trace-info-condition info) (cons nil nil)) (setf (trace-info-condition-after info) value)) (:condition-all (setf (trace-info-condition info) value) (setf (trace-info-condition-after info) value)) (:wherein (setf (trace-info-wherein info) (collect-names value))) (:wherein-only (setf (trace-info-wherein-only info) (collect-names value))) (:encapsulate (setf (trace-info-encapsulated info) (car value))) (:break (setf (trace-info-break info) value)) (:break-after (setf (trace-info-break-after info) value)) (:break-all (setf (trace-info-break info) value) (setf (trace-info-break-after info) value)) (:print (setf (trace-info-print info) (append (trace-info-print info) (list value)))) (:print-after (setf (trace-info-print-after info) (append (trace-info-print-after info) (list value)))) (:print-all (setf (trace-info-print info) (append (trace-info-print info) (list value))) (setf (trace-info-print-after info) (append (trace-info-print-after info) (list value)))) (t (return))) (pop current) (unless current (error (intl:gettext "Missing argument to ~S TRACE option.") option)) (pop current))) current))) ;;; EXPAND-TRACE -- Internal ;;; ;;; Compute the expansion of TRACE in the non-trivial case (arguments ;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This ;;; allows TRACE to be used without the full interpreter. ;;; (defun expand-trace (specs) (collect ((binds) (forms)) (let* ((global-options (make-trace-info)) (current (parse-trace-options specs global-options))) (loop (when (endp current) (return)) (let ((name (pop current)) (options (copy-trace-info global-options))) (cond ((eq name :function) (let ((temp (gensym))) (binds `(,temp ,(pop current))) (forms `(trace-1 ,temp ',options)))) ;; ;; Generic function -> trace all method functions. ((eq name :methods) (let ((tem (gensym))) (binds `(,tem ,(pop current))) (forms `(dolist (name (all-method-function-names ,tem)) (when (fboundp name) (trace-1 name ',options)))))) ((and (keywordp name) (not (or (fboundp name) (macro-function name)))) (error (intl:gettext "Unknown TRACE option: ~S") name)) ;; ;; Method name -> trace method functions. ((and (consp name) (eq (car name) 'method)) (when (fboundp name) (forms `(trace-1 ',name ',options))) (let ((name `(pcl::fast-method ,@(cdr name)))) (when (fboundp name) (forms `(trace-1 ',name ',options))))) (t (forms `(trace-1 ',name ',options)))) (setq current (parse-trace-options current options))))) (if (binds) `(let ,(binds) (list ,@(forms))) `(list ,@(forms))))) ;;; %LIST-TRACED-FUNCTIONS -- Internal ;;; (defun %list-traced-functions () (loop for x being each hash-value in *traced-functions* collect (trace-info-what x))) ;;; TRACE -- Public. ;;; (defmacro trace (&rest specs) "TRACE {Option Global-Value}* {Name {Option Value}*}* TRACE is a debugging tool that prints information when specified functions are called. In its simplest form: (trace Name-1 Name-2 ...) CLOS methods can be traced by specifying a name of the form (METHOD {Qualifier}* ({Specializer}*)). Labels and Flet functions can be traced by specifying a name of the form (LABELS ) or (FLET ) where is the Labels/Flet function in . TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named functions is entered or returns (the Names are not evaluated.) The output is indented according to the number of pending traced calls, and this trace depth is printed at the beginning of each line of output. Options allow modification of the default behavior. Each option is a pair of an option keyword and a value form. Options may be interspersed with function names. Options only affect tracing of the function whose name they appear immediately after. Global options are specified before the first name, and affect all functions traced by a given use of TRACE. The following options are defined: :CONDITION Form :CONDITION-AFTER Form :CONDITION-ALL Form If :CONDITION is specified, then TRACE does nothing unless Form evaluates to true at the time of the call. :CONDITION-AFTER is similar, but suppresses the initial printout, and is tested when the function returns. :CONDITION-ALL tries both before and after. :WHEREIN Names If specified, Names is a function name or list of names. TRACE does nothing unless a call to one of those functions encloses the call to this function (i.e. it would appear in a backtrace.) Anonymous functions have string names like \"DEFUN FOO\". :WHEREIN-ONLY Names Like :WHEREIN, but only if the immediate caller is one of Names, instead of being any where in a backtrace. :BREAK Form :BREAK-AFTER Form :BREAK-ALL Form If specified, and Form evaluates to true, then the debugger is invoked at the start of the function, at the end of the function, or both, according to the respective option. :PRINT Form :PRINT-AFTER Form :PRINT-ALL Form In addition to the usual printout, the result of evaluating FORM is printed at the start of the function, at the end of the function, or both, according to the respective option. Multiple print options cause multiple values to be printed. :FUNCTION Function-Form This is a not really an option, but rather another way of specifying what function to trace. The Function-Form is evaluated immediately, and the resulting function is traced. :METHODS Function-Form This is a not really an option, but rather a way of specifying that all methods of a generic functions should be traced. The Function-Form is evaluated immediately, and the methods of the resulting generic function are traced. :ENCAPSULATE {:DEFAULT | T | NIL} If T, the tracing is done via encapsulation (redefining the function name) rather than by modifying the function. :DEFAULT is the default, and means to use encapsulation for interpreted functions and funcallable instances, breakpoints otherwise. When encapsulation is used, forms are *not* evaluated in the function's lexical environment, but DEBUG:ARG can still be used. :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment of the called function; DEBUG:VAR and DEBUG:ARG can be used. The -AFTER and -ALL forms are evaluated in the null environment." (if specs (expand-trace specs) '(%list-traced-functions))) ;;;; Untracing: ;;; UNTRACE-1 -- Internal ;;; ;;; Untrace one function. ;;; (defun untrace-1 (function-or-name) (multiple-value-bind (fun named kind local) (trace-fdefinition function-or-name) (declare (ignore named kind)) (let* ((key (or local fun)) (info (gethash key *traced-functions*))) (cond ((not info) (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name)) (t (cond ((trace-info-encapsulated info) (funwrap (trace-info-what info) :type 'trace)) (t (di:delete-breakpoint (trace-info-start-breakpoint info)) (di:delete-breakpoint (trace-info-end-breakpoint info)))) (setf (trace-info-untraced info) t) (remhash key *traced-functions*)))))) ;;; UNTRACE-ALL -- Internal ;;; ;;; Untrace all traced functions. ;;; (defun untrace-all () (dolist (fun (%list-traced-functions)) (untrace-1 fun)) t) (defmacro untrace (&rest specs) "Removes tracing from the specified functions. With no args, untraces all functions." (if specs (collect ((res)) (let ((current specs)) (loop (unless current (return)) (let ((name (pop current))) (cond ((eq name :function) (res `(untrace-1 ,(pop current)))) ;; ;; Method name -> untrace existing method functions. ((and (consp name) (eq (car name) 'method)) (when (fboundp name) (res `(untrace-1 ',name))) (let ((name `(pcl::fast-method ,@(cdr name)))) (when (fboundp name) (res `(untrace-1 ',name))))) ;; ;; Generic function -> untrace all method functions. ((eq name :methods) (res `(dolist (name (all-method-function-names ,(pop current))) (when (fboundp name) (untrace-1 name))))) (t (res `(untrace-1 ',name)))))) `(progn ,@(res) t))) '(untrace-all))) cmucl-21a/src/code/numbers.lisp000066400000000000000000001445621260377556400166420ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/numbers.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; ;;; This file contains the definitions of most number functions. ;;; ;;; Author: Rob MacLachlan ;;; ;;; Much code in this file was derived from code written by William Lott, Dave ;;; Mcdonald, Jim Large, Scott Fahlman, etc. ;;; Long-float support by Douglas Crosher, 1998. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(zerop plusp minusp oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate abs phase signum float floor ceiling truncate cis round mod rem ffloor fceiling fround ftruncate complex realpart imagpart logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1 logorc2 boole boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2 boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1 boole-andc2 boole-orc1 boole-orc2 lognot logtest logbitp ash integer-length byte byte-size byte-position ldb ldb-test mask-field dpb deposit-field upgraded-complex-part-type)) (in-package "KERNEL") ;;;; Number dispatch macro: (eval-when (compile load eval) ;;; PARSE-NUMBER-DISPATCH -- Internal ;;; ;;; Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the ;;; type dispatches and bodies. Result is a tree built of alists representing ;;; the dispatching off each arg (in order). The leaf is the body to be ;;; executed in that case. ;;; (defun parse-number-dispatch (vars result types var-types body) (cond ((null vars) (unless (null types) (error (intl:gettext "More types than vars."))) (when (cdr result) (error (intl:gettext "Duplicate case: ~S.") body)) (setf (cdr result) (sublis var-types body :test #'equal))) ((null types) (error (intl:gettext "More vars than types."))) (t (flet ((frob (var type) (parse-number-dispatch (rest vars) (or (assoc type (cdr result) :test #'equal) (car (setf (cdr result) (acons type nil (cdr result))))) (rest types) (acons `(dispatch-type ,var) type var-types) body))) (let ((type (first types)) (var (first vars))) (if (and (consp type) (eq (first type) 'foreach)) (dolist (type (rest type)) (frob var type)) (frob var type))))))) ;;; Our guess for the preferred order to do type tests in (cheaper and/or more ;;; probable first.) ;;; (defconstant type-test-ordering '(fixnum single-float double-float integer #+long-float long-float #+double-double double-double-float bignum complex ratio)) ;;; Type-Test-Order -- Internal ;;; ;;; Return true if Type1 should be tested before Type2. ;;; (defun type-test-order (type1 type2) (let ((o1 (position type1 type-test-ordering)) (o2 (position type2 type-test-ordering))) (cond ((not o1) nil) ((not o2) t) (t (< o1 o2))))) ;;; GENERATE-NUMBER-DISPATCH -- Internal ;;; ;;; Return an ETYPECASE form that does the type dispatch, ordering the cases ;;; for efficiency. ;;; (defun generate-number-dispatch (vars error-tags cases) (if vars (let ((var (first vars)) (cases (sort cases #'type-test-order :key #'car))) `((typecase ,var ,@(mapcar #'(lambda (case) `(,(first case) ,@(generate-number-dispatch (rest vars) (rest error-tags) (cdr case)))) cases) (t (go ,(first error-tags)))))) cases)) ); Eval-When (Compile Load Eval) ;;; NUMBER-DISPATCH -- Interface ;;; (defmacro number-dispatch (var-specs &body cases) "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}* A vaguely case-like macro that does number cross-product dispatches. The Vars are the variables we are dispatching off of. The Type paired with each Var is used in the error message when no case matches. Each case specifies a Type for each var, and is executed when that signature holds. A type may be a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated for every Each-Type. In the body of each case, any list of the form (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that instance of the case. As an alternate to a case spec, there may be a form whose CAR is a symbol. In this case, we apply the CAR of the form to the CDR and treat the result of the call as a list of cases. This process is not applied recursively." (let ((res (list nil)) (vars (mapcar #'car var-specs)) (block (gensym))) (dolist (case cases) (if (symbolp (first case)) (let ((cases (apply (symbol-function (first case)) (rest case)))) (dolist (case cases) (parse-number-dispatch vars res (first case) nil (rest case)))) (parse-number-dispatch vars res (first case) nil (rest case)))) (collect ((errors) (error-tags)) (dolist (spec var-specs) (let ((var (first spec)) (type (second spec)) (tag (gensym))) (error-tags tag) (errors tag) (errors `(return-from ,block (error 'simple-type-error :datum ,var :expected-type ',type :format-control (intl:gettext "Argument ~A is not a ~S: ~S.") :format-arguments (list ',var ',type ,var)))))) `(block ,block (tagbody (return-from ,block ,@(generate-number-dispatch vars (error-tags) (cdr res))) ,@(errors)))))) ;;;; Binary operation dispatching utilities: (eval-when (compile eval) ;;; FLOAT-CONTAGION -- Internal ;;; ;;; Return NUMBER-DISPATCH forms for rational X float. ;;; (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio))) `(((single-float single-float) (,op ,x ,y)) (((foreach ,@rat-types) (foreach single-float double-float #+long-float long-float #+double-double double-double-float)) (,op (coerce ,x '(dispatch-type ,y)) ,y)) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float) (foreach ,@rat-types)) (,op ,x (coerce ,y '(dispatch-type ,x)))) #+long-float (((foreach single-float double-float long-float) long-float) (,op (coerce ,x 'long-float) ,y)) #+long-float ((long-float (foreach single-float double-float)) (,op ,x (coerce ,y 'long-float))) #+double-double (((foreach single-float double-float double-double-float) double-double-float) (,op (coerce ,x 'double-double-float) ,y)) #+double-double ((double-double-float (foreach single-float double-float)) (,op ,x (coerce ,y 'double-double-float))) (((foreach single-float double-float) double-float) (,op (coerce ,x 'double-float) ,y)) ((double-float single-float) (,op ,x (coerce ,y 'double-float))))) ;;; BIGNUM-CROSS-FIXNUM -- Internal ;;; ;;; Return NUMBER-DISPATCH forms for bignum X fixnum. ;;; (defun bignum-cross-fixnum (fix-op big-op) `(((fixnum fixnum) (,fix-op x y)) ((fixnum bignum) (,big-op (make-small-bignum x) y)) ((bignum fixnum) (,big-op x (make-small-bignum y))) ((bignum bignum) (,big-op x y)))) ); Eval-When (Compile Eval) ;;;; Canonicalization utilities: ;;; CANONICAL-COMPLEX -- Internal ;;; ;;; If imagpart is 0, return realpart, otherwise make a complex. This is ;;; used when we know that realpart and imagpart are the same type, but ;;; rational canonicalization might still need to be done. ;;; (declaim (inline canonical-complex)) (defun canonical-complex (realpart imagpart) (if (eql imagpart 0) realpart (cond #+long-float ((and (typep realpart 'long-float) (typep imagpart 'long-float)) (truly-the (complex long-float) (complex realpart imagpart))) #+double-double ((and (typep realpart 'double-double-float) (typep imagpart 'double-double-float)) (truly-the (complex double-double-float) (complex realpart imagpart))) ((and (typep realpart 'double-float) (typep imagpart 'double-float)) (truly-the (complex double-float) (complex realpart imagpart))) ((and (typep realpart 'single-float) (typep imagpart 'single-float)) (truly-the (complex single-float) (complex realpart imagpart))) (t (%make-complex realpart imagpart))))) ;;; BUILD-RATIO -- Internal ;;; ;;; Given a numerator and denominator with the GCD already divided out, make ;;; a canonical rational. We make the denominator positive, and check whether ;;; it is 1. ;;; (declaim (inline build-ratio)) (defun build-ratio (num den) (multiple-value-bind (num den) (if (minusp den) (values (- num) (- den)) (values num den)) (cond ((eql den 1) num) ((eql den 0) (error 'division-by-zero :operands (list num den) :operation 'build-ratio)) (t (%make-ratio num den))))) ;;; MAYBE-TRUNCATE -- Internal ;;; ;;; Truncate X and Y, but bum the case where Y is 1. ;;; (declaim (inline maybe-truncate)) (defun maybe-truncate (x y) (if (eql y 1) x (truncate x y))) ;;;; Complexes: (defun upgraded-complex-part-type (spec &optional environment) "Returns the element type of the most specialized COMPLEX number type that can hold parts of type Spec." (declare (ignore environment)) (cond ((subtypep spec 'single-float) 'single-float) ((subtypep spec 'double-float) 'double-float) #+long-float ((subtypep spec 'long-float) 'long-float) #+double-double ((subtypep spec 'double-double-float) 'double-double-float) ((subtypep spec 'rational) 'rational) ((subtypep spec 'real) ;; CMUCL doesn't have a specialized type for any other type ;; of complex---only single-float and double-float (and ;; long-float) have specialized complex types. 'real) ((kernel::hairy-type-p (specifier-type spec)) ;; Do we really want to produce this error here? (cerror (intl:gettext "Assume this is a subtype of REAL anyway.") (intl:gettext "Cannot determine if ~S is a subtype of REAL.") spec) 'real) (t ;; Expected type really should be something else... (error 'type-error :datum spec :expected-type 'real :format-control (intl:gettext "Complex numbers cannot have components of type ~S.") :format-arguments (list spec))))) (defun complex (realpart &optional (imagpart 0)) "Builds a complex number from the specified components." (flet ((%%make-complex (realpart imagpart) (cond #+long-float ((and (typep realpart 'long-float) (typep imagpart 'long-float)) (truly-the (complex long-float) (complex realpart imagpart))) #+double-double ((and (typep realpart 'double-double-float) (typep imagpart 'double-double-float)) (truly-the (complex double-double-float) (complex realpart imagpart))) ((and (typep realpart 'double-float) (typep imagpart 'double-float)) (truly-the (complex double-float) (complex realpart imagpart))) ((and (typep realpart 'single-float) (typep imagpart 'single-float)) (truly-the (complex single-float) (complex realpart imagpart))) (t (%make-complex realpart imagpart))))) (number-dispatch ((realpart real) (imagpart real)) ((rational rational) (canonical-complex realpart imagpart)) (float-contagion %%make-complex realpart imagpart (rational))))) (defun realpart (number) "Extracts the real part of a number." (typecase number #+long-float ((complex long-float) (truly-the long-float (realpart number))) #+double-double ((complex double-double-float) (truly-the double-double-float (realpart number))) ((complex double-float) (truly-the double-float (realpart number))) ((complex single-float) (truly-the single-float (realpart number))) ((complex rational) (kernel:%realpart number)) (t number))) (defun imagpart (number) "Extracts the imaginary part of a number." (typecase number #+long-float ((complex long-float) (truly-the long-float (imagpart number))) #+double-double ((complex double-double-float) (truly-the double-double-float (imagpart number))) ((complex double-float) (truly-the double-float (imagpart number))) ((complex single-float) (truly-the single-float (imagpart number))) ((complex rational) (kernel:%imagpart number)) (float (float 0 number)) (t 0))) (defun conjugate (number) "Returns the complex conjugate of NUMBER. For non-complex numbers, this is an identity." (if (complexp number) (complex (realpart number) (- (imagpart number))) number)) (defun signum (number) "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." (if (zerop number) number (if (rationalp number) (if (plusp number) 1 -1) (/ number (abs number))))) ;;;; Ratios. (defun numerator (number) "Return the numerator of NUMBER, which must be rational." (numerator number)) (defun denominator (number) "Return the denominator of NUMBER, which must be rational." (denominator number)) ;;;; Arithmetic Operations (defmacro define-arith (op init doc) `(defun ,op (&rest args) ,doc (if (null args) ,init (do ((args (cdr args) (cdr args)) (res (car args) (,op res (car args)))) ((null args) res))))) (define-arith + 0 "Returns the sum of its arguments. With no args, returns 0.") (define-arith * 1 "Returns the product of its arguments. With no args, returns 1.") (defun - (number &rest more-numbers) "Subtracts the second and all subsequent arguments from the first. With one arg, negates it." (if more-numbers (do ((nlist more-numbers (cdr nlist)) (result number)) ((atom nlist) result) (declare (list nlist)) (setq result (- result (car nlist)))) (- number))) (defun / (number &rest more-numbers) "Divides the first arg by each of the following arguments, in turn. With one arg, returns reciprocal." (if more-numbers (do ((nlist more-numbers (cdr nlist)) (result number)) ((atom nlist) result) (declare (list nlist)) (setq result (/ result (car nlist)))) (/ number))) (defun 1+ (number) "Returns NUMBER + 1." (1+ number)) (defun 1- (number) "Returns NUMBER - 1." (1- number)) (eval-when (compile) (defmacro two-arg-+/- (name op big-op) `(defun ,name (x y) (number-dispatch ((x number) (y number)) (bignum-cross-fixnum ,op ,big-op) (float-contagion ,op x y) ((complex complex) (canonical-complex (,op (realpart x) (realpart y)) (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float #+long-float long-float #+double-double double-double-float) complex) (complex (,op x (realpart y)) (,op 0 (imagpart y)))) ((complex (or rational float)) (complex (,op (realpart x) y) (,op (imagpart x) 0))) (((foreach fixnum bignum) ratio) (let* ((dy (denominator y)) (n (,op (* x dy) (numerator y)))) (%make-ratio n dy))) ((ratio integer) (let* ((dx (denominator x)) (n (,op (numerator x) (* y dx)))) (%make-ratio n dx))) ((ratio ratio) (let* ((nx (numerator x)) (dx (denominator x)) (ny (numerator y)) (dy (denominator y)) (g1 (gcd dx dy))) (if (eql g1 1) (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy)) (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny))) (g2 (gcd t1 g1)) (t2 (truncate dx g1))) (cond ((eql t1 0) 0) ((eql g2 1) (%make-ratio t1 (* t2 dy))) (T (let* ((nn (truncate t1 g2)) (t3 (truncate dy g2)) (nd (if (eql t2 1) t3 (* t2 t3)))) (if (eql nd 1) nn (%make-ratio nn nd)))))))))))) ); Eval-When (Compile) (two-arg-+/- two-arg-+ + add-bignums) (two-arg-+/- two-arg-- - subtract-bignum) (defun two-arg-* (x y) (flet ((integer*ratio (x y) (if (eql x 0) 0 (let* ((ny (numerator y)) (dy (denominator y)) (gcd (gcd x dy))) (if (eql gcd 1) (%make-ratio (* x ny) dy) (let ((nn (* (truncate x gcd) ny)) (nd (truncate dy gcd))) (if (eql nd 1) nn (%make-ratio nn nd))))))) (complex*real (x y) (canonical-complex (* (realpart x) y) (* (imagpart x) y)))) (number-dispatch ((x number) (y number)) (float-contagion * x y) ((fixnum fixnum) (multiply-fixnums x y)) ((bignum fixnum) (multiply-bignum-and-fixnum x y)) ((fixnum bignum) (multiply-bignum-and-fixnum y x)) ((bignum bignum) (multiply-bignums x y)) ((complex complex) (let* ((rx (realpart x)) (ix (imagpart x)) (ry (realpart y)) (iy (imagpart y))) (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) (((foreach bignum fixnum ratio single-float double-float #+long-float long-float #+double-double double-double-float) complex) (complex*real y x)) ((complex (or rational float)) (complex*real x y)) (((foreach bignum fixnum) ratio) (integer*ratio x y)) ((ratio integer) (integer*ratio y x)) ((ratio ratio) (let* ((nx (numerator x)) (dx (denominator x)) (ny (numerator y)) (dy (denominator y)) (g1 (gcd nx dy)) (g2 (gcd dx ny))) (build-ratio (* (maybe-truncate nx g1) (maybe-truncate ny g2)) (* (maybe-truncate dx g2) (maybe-truncate dy g1)))))))) ;;; INTEGER-/-INTEGER -- Internal ;;; ;;; Divide two integers, producing a canonical rational. If a fixnum, we ;;; see if they divide evenly before trying the GCD. In the bignum case, we ;;; don't bother, since bignum division is expensive, and the test is not very ;;; likely to suceed. ;;; (defun integer-/-integer (x y) (if (and (typep x 'fixnum) (typep y 'fixnum)) (multiple-value-bind (quo rem) (truncate x y) (if (zerop rem) quo (let ((gcd (gcd x y))) (declare (fixnum gcd)) (if (eql gcd 1) (build-ratio x y) (build-ratio (truncate x gcd) (truncate y gcd)))))) (let ((gcd (gcd x y))) (if (eql gcd 1) (build-ratio x y) (build-ratio (truncate x gcd) (truncate y gcd)))))) (defun two-arg-/ (x y) (number-dispatch ((x number) (y number)) (float-contagion / x y (ratio integer)) ((complex complex) (let* ((rx (realpart x)) (ix (imagpart x)) (ry (realpart y)) (iy (imagpart y))) (if (> (abs ry) (abs iy)) (let* ((r (/ iy ry)) (dn (+ ry (* r iy)))) (canonical-complex (/ (+ rx (* ix r)) dn) (/ (- ix (* rx r)) dn))) (let* ((r (/ ry iy)) (dn (+ iy (* r ry)))) (canonical-complex (/ (+ (* rx r) ix) dn) (/ (- (* ix r) rx) dn)))))) (((foreach integer ratio single-float double-float) complex) (let* ((ry (realpart y)) (iy (imagpart y))) (if (> (abs ry) (abs iy)) (let* ((r (/ iy ry)) (dn (* ry (+ 1 (* r r))))) (canonical-complex (/ x dn) (/ (- (* x r)) dn))) (let* ((r (/ ry iy)) (dn (* iy (+ 1 (* r r))))) (canonical-complex (/ (* x r) dn) (/ (- x) dn)))))) ((complex (or rational float)) (canonical-complex (/ (realpart x) y) (/ (imagpart x) y))) ((ratio ratio) (let* ((nx (numerator x)) (dx (denominator x)) (ny (numerator y)) (dy (denominator y)) (g1 (gcd nx ny)) (g2 (gcd dx dy))) (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2)) (* (maybe-truncate dx g2) (maybe-truncate ny g1))))) ((integer integer) (integer-/-integer x y)) ((integer ratio) (if (zerop x) 0 (let* ((ny (numerator y)) (dy (denominator y)) (gcd (gcd x ny))) (build-ratio (* (maybe-truncate x gcd) dy) (maybe-truncate ny gcd))))) ((ratio integer) (let* ((nx (numerator x)) (gcd (gcd nx y))) (build-ratio (maybe-truncate nx gcd) (* (maybe-truncate y gcd) (denominator x))))))) (defun %negate (n) (number-dispatch ((n number)) (((foreach fixnum single-float double-float #+long-float long-float)) (%negate n)) #+double-double ((double-double-float) (multiple-value-bind (hi lo) (c::neg-dd (kernel:double-double-hi n) (kernel:double-double-lo n)) (kernel:make-double-double-float hi lo))) ((bignum) (negate-bignum n)) ((ratio) (%make-ratio (- (numerator n)) (denominator n))) ((complex) (complex (- (realpart n)) (- (imagpart n)))))) ;;;; Truncate & friends. (defun truncate (number &optional (divisor 1)) "Returns number (or number/divisor) as an integer, rounded toward 0. The second returned value is the remainder." (macrolet ((truncate-float (rtype) `(let* ((float-div (coerce divisor ',rtype)) (res (%unary-truncate (/ number float-div)))) (values res (- number (* (coerce res ',rtype) float-div)))))) (number-dispatch ((number real) (divisor real)) ((fixnum fixnum) (truncate number divisor)) (((foreach fixnum bignum) ratio) (let ((q (truncate (* number (denominator divisor)) (numerator divisor)))) (values q (- number (* q divisor))))) ((fixnum bignum) (bignum-truncate (make-small-bignum number) divisor)) ((ratio (or float rational)) (let ((q (truncate (numerator number) (* (denominator number) divisor)))) (values q (- number (* q divisor))))) ((bignum fixnum) (bignum-truncate number (make-small-bignum divisor))) ((bignum bignum) (bignum-truncate number divisor)) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float) (or rational single-float)) (if (eql divisor 1) (let ((res (%unary-truncate number))) (values res (- number (coerce res '(dispatch-type number))))) (truncate-float (dispatch-type number)))) #+long-float ((long-float (or single-float double-float long-float)) (truncate-float long-float)) #+long-float (((foreach double-float single-float) long-float) (truncate-float long-float)) #+double-double ((double-double-float (or single-float double-float double-double-float)) (truncate-float double-double-float)) #+double-double (((foreach single-float double-float) double-double-float) (truncate-float double-double-float)) ((double-float (or single-float double-float)) (truncate-float double-float)) ((single-float double-float) (truncate-float double-float)) (((foreach fixnum bignum ratio) (foreach single-float double-float #+double-double double-double-float #+long-float long-float)) (truncate-float (dispatch-type divisor)))))) ;;; Declare these guys inline to let them get optimized a little. Round and ;;; Fround are not declared inline since they seem too obscure and too ;;; big to inline-expand by default. Also, this gives the compiler a chance to ;;; pick off the unary float case. Simlarly, ceiling and floor are only ;;; maybe-inline for now, so that the power-of-2 ceiling and floor transforms ;;; get a chance. ;;; ;;; Don't inline ftruncate because it's probably too big now. ;;; (declaim (inline rem mod fceiling ffloor)) (declaim (maybe-inline ceiling floor)) ;;; If the numbers do not divide exactly and the result of (/ number divisor) ;;; would be negative then decrement the quotient and augment the remainder by ;;; the divisor. ;;; (defun floor (number &optional (divisor 1)) "Returns the greatest integer not greater than number, or number/divisor. The second returned value is (mod number divisor)." (multiple-value-bind (tru rem) (truncate number divisor) (if (and (not (zerop rem)) (if (minusp divisor) (plusp number) (minusp number))) (values (1- tru) (+ rem divisor)) (values tru rem)))) ;;; If the numbers do not divide exactly and the result of (/ number divisor) ;;; would be positive then increment the quotient and decrement the remainder by ;;; the divisor. ;;; (defun ceiling (number &optional (divisor 1)) "Returns the smallest integer not less than number, or number/divisor. The second returned value is the remainder." (multiple-value-bind (tru rem) (truncate number divisor) (if (and (not (zerop rem)) (if (minusp divisor) (minusp number) (plusp number))) (values (+ tru 1) (- rem divisor)) (values tru rem)))) (defun round (number &optional (divisor 1)) "Rounds number (or number/divisor) to nearest integer. The second returned value is the remainder." (if (eql divisor 1) (round number) (multiple-value-bind (tru rem) (truncate number divisor) (if (zerop rem) (values tru rem) (let ((thresh (/ (abs divisor) 2))) (cond ((or (> rem thresh) (and (= rem thresh) (oddp tru))) (if (minusp divisor) (values (- tru 1) (+ rem divisor)) (values (+ tru 1) (- rem divisor)))) ((let ((-thresh (- thresh))) (or (< rem -thresh) (and (= rem -thresh) (oddp tru)))) (if (minusp divisor) (values (+ tru 1) (- rem divisor)) (values (- tru 1) (+ rem divisor)))) (t (values tru rem)))))))) (defun rem (number divisor) "Returns second result of TRUNCATE." (multiple-value-bind (tru rem) (truncate number divisor) (declare (ignore tru)) rem)) (defun mod (number divisor) "Returns second result of FLOOR." (let ((rem (rem number divisor))) (if (and (not (zerop rem)) (if (minusp divisor) (plusp number) (minusp number))) (+ rem divisor) rem))) (defun ftruncate (number &optional (divisor 1)) "Same as TRUNCATE, but returns first value as a float." (macrolet ((truncate-float (rtype) `(let* ((float-div (coerce divisor ',rtype)) (res (%unary-ftruncate (/ number float-div)))) (values res (- number (* (coerce res ',rtype) float-div)))))) (number-dispatch ((number real) (divisor real)) (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) (multiple-value-bind (q r) (truncate number divisor) (values (float q) r))) (((foreach single-float double-float #+double-double double-double-float) (or rational single-float)) (if (eql divisor 1) (let ((res (%unary-ftruncate number))) (values res (- number (coerce res '(dispatch-type number))))) (truncate-float (dispatch-type number)))) ((double-float (or single-float double-float)) (truncate-float double-float)) ((single-float double-float) (truncate-float double-float)) (((foreach fixnum bignum ratio) (foreach single-float double-float #+double-double double-double-float)) (truncate-float (dispatch-type divisor))) #+double-double ((double-double-float (or single-float double-float double-double-float)) (truncate-float double-double-float)) #+double-double (((foreach single-float double-float) double-double-float) (truncate-float double-double-float))))) (defun ffloor (number &optional (divisor 1)) "Same as FLOOR, but returns first value as a float." (multiple-value-bind (tru rem) (ftruncate number divisor) (if (and (not (zerop rem)) (if (minusp divisor) (plusp number) (minusp number))) (values (1- tru) (+ rem divisor)) (values tru rem)))) (defun fceiling (number &optional (divisor 1)) "Same as CEILING, but returns first value as a float." (multiple-value-bind (tru rem) (ftruncate number divisor) (if (and (not (zerop rem)) (if (minusp divisor) (minusp number) (plusp number))) (values (+ tru 1) (- rem divisor)) (values tru rem)))) (defun fround (number &optional (divisor 1)) "Same as ROUND, but returns first value as a float." (multiple-value-bind (res rem) (round number divisor) (values (float res (if (floatp rem) rem 1.0)) rem))) ;;;; Comparisons: (defun = (number &rest more-numbers) "Returns T if all of its arguments are numerically equal, NIL otherwise." (declare (optimize (safety 2)) (number number) (dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) T) (declare (list nlist)) (if (not (= (car nlist) number)) (return nil)))) (defun /= (number &rest more-numbers) "Returns T if no two of its arguments are numerically equal, NIL otherwise." (declare (optimize (safety 2)) (number number) (dynamic-extent more-numbers)) (do* ((head number (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist) (number head)) (unless (do* ((nl nlist (cdr nl))) ((atom nl) T) (declare (list nl)) (if (= head (car nl)) (return nil))) (return nil)))) (defun < (number &rest more-numbers) "Returns T if its arguments are in strictly increasing order, NIL otherwise." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (do* ((n number (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist) (real n)) (if (not (< n (car nlist))) (return nil)))) (defun > (number &rest more-numbers) "Returns T if its arguments are in strictly decreasing order, NIL otherwise." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (do* ((n number (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist) (real n)) (if (not (> n (car nlist))) (return nil)))) (defun <= (number &rest more-numbers) "Returns T if arguments are in strictly non-decreasing order, NIL otherwise." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (do* ((n number (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist) (real n)) (if (not (<= n (car nlist))) (return nil)))) (defun >= (number &rest more-numbers) "Returns T if arguments are in strictly non-increasing order, NIL otherwise." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (do* ((n number (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist) (real n)) (if (not (>= n (car nlist))) (return nil)))) (defun max (number &rest more-numbers) "Returns the greatest of its arguments." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (dolist (real more-numbers) (when (> (the real real) number) (setq number real))) (the real number)) (defun min (number &rest more-numbers) "Returns the least of its arguments." (declare (optimize (safety 2)) (real number) (dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result (the real number))) ((null nlist) (return result)) (declare (list nlist)) (if (< (car nlist) result) (setq result (car nlist))))) (eval-when (compile eval) (defun basic-compare (op) `(((fixnum fixnum) (,op x y)) ((single-float single-float) (,op x y)) #+long-float (((foreach single-float double-float long-float) long-float) (,op (coerce x 'long-float) y)) #+long-float ((long-float (foreach single-float double-float)) (,op x (coerce y 'long-float))) #+double-double (((foreach single-float double-float double-double-float) double-double-float) (,op (coerce x 'double-double-float) y)) #+double-double ((double-double-float (foreach single-float double-float)) (,op x (coerce y 'double-double-float))) (((foreach single-float double-float) double-float) (,op (coerce x 'double-float) y)) ((double-float single-float) (,op x (coerce y 'double-float))) (((foreach single-float double-float #+long-float long-float #+double-double double-double-float) rational) ;; Comparing infinity against any rational produces the same ;; answer as comparing infinity against 0. Comparison against ;; zero is quite common, so add a special case for that. (if (or (eql y 0) (float-infinity-p x)) (,op x (coerce 0 '(dispatch-type x))) (,op (rational x) y))) (((foreach bignum fixnum ratio) float) (if (or (eql x 0) (float-infinity-p y)) (,op (coerce 0 '(dispatch-type y)) y) (,op x (rational y)))))) (defmacro two-arg- (name op ratio-arg1 ratio-arg2 &rest cases) `(defun ,name (x y) (number-dispatch ((x real) (y real)) (basic-compare ,op) (((foreach fixnum bignum) ratio) (,op x (,ratio-arg2 (numerator y) (denominator y)))) ((ratio integer) (,op (,ratio-arg1 (numerator x) (denominator x)) y)) ((ratio ratio) (,op (* (numerator (truly-the ratio x)) (denominator (truly-the ratio y))) (* (numerator (truly-the ratio y)) (denominator (truly-the ratio x))))) ,@cases))) ); Eval-When (Compile Eval) (two-arg- two-arg-< < floor ceiling ((fixnum bignum) (bignum-plus-p y)) ((bignum fixnum) (not (bignum-plus-p x))) ((bignum bignum) (minusp (bignum-compare x y)))) (two-arg- two-arg-> > ceiling floor ((fixnum bignum) (not (bignum-plus-p y))) ((bignum fixnum) (bignum-plus-p x)) ((bignum bignum) (plusp (bignum-compare x y)))) (defun two-arg-= (x y) (number-dispatch ((x number) (y number)) (basic-compare =) ((fixnum (or bignum ratio)) nil) ((bignum (or fixnum ratio)) nil) ((bignum bignum) (zerop (bignum-compare x y))) ((ratio integer) nil) ((ratio ratio) (and (eql (numerator x) (numerator y)) (eql (denominator x) (denominator y)))) ((complex complex) (and (= (realpart x) (realpart y)) (= (imagpart x) (imagpart y)))) (((foreach fixnum bignum ratio single-float double-float #+long-float long-float #+double-double double-double-float) complex) (and (= x (realpart y)) (zerop (imagpart y)))) ((complex (or float rational)) (and (= (realpart x) y) (zerop (imagpart x)))))) ;;; EQL -- Public ;;; (defun eql (obj1 obj2) "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL." (or (eq obj1 obj2) (if (or (typep obj2 'fixnum) (not (typep obj2 'number))) nil (macrolet ((foo (&rest stuff) `(typecase obj2 ,@(mapcar #'(lambda (foo) (let ((type (car foo)) (fn (cadr foo))) `(,type (and (typep obj1 ',type) (,fn obj1 obj2))))) stuff)))) (foo (single-float eql) (double-float eql) #+long-float (long-float eql) (bignum (lambda (x y) (zerop (bignum-compare x y)))) (ratio (lambda (x y) (and (eql (numerator x) (numerator y)) (eql (denominator x) (denominator y))))) #+double-double (double-double-float eql) (complex (lambda (x y) (and (eql (realpart x) (realpart y)) (eql (imagpart x) (imagpart y)))))))))) ;;;; Logicals: (defun logior (&rest integers) "Returns the bit-wise or of its arguments. Args must be integers." (declare (list integers)) (if integers (do ((result (the integer (pop integers)) (logior result (pop integers)))) ((null integers) result)) 0)) (defun logxor (&rest integers) "Returns the bit-wise exclusive or of its arguments. Args must be integers." (declare (list integers)) (if integers (do ((result (the integer (pop integers)) (logxor result (pop integers)))) ((null integers) result)) 0)) (defun logand (&rest integers) "Returns the bit-wise and of its arguments. Args must be integers." (declare (list integers)) (if integers (do ((result (the integer (pop integers)) (logand result (pop integers)))) ((null integers) result)) -1)) (defun logeqv (&rest integers) "Returns the bit-wise equivalence of its arguments. Args must be integers." (declare (list integers)) (if integers (do ((result (the integer (pop integers)) (logeqv result (pop integers)))) ((null integers) result)) -1)) #-modular-arith (progn (defun lognand (integer1 integer2) _N"Returns the complement of the logical AND of integer1 and integer2." (lognand integer1 integer2)) (defun lognor (integer1 integer2) _N"Returns the complement of the logical OR of integer1 and integer2." (lognor integer1 integer2)) (defun logandc1 (integer1 integer2) _N"Returns the logical AND of (LOGNOT integer1) and integer2." (logandc1 integer1 integer2)) (defun logandc2 (integer1 integer2) _N"Returns the logical AND of integer1 and (LOGNOT integer2)." (logandc2 integer1 integer2)) (defun logorc1 (integer1 integer2) _N"Returns the logical OR of (LOGNOT integer1) and integer2." (logorc1 integer1 integer2)) (defun logorc2 (integer1 integer2) _N"Returns the logical OR of integer1 and (LOGNOT integer2)." (logorc2 integer1 integer2)) ) (defun lognot (number) "Returns the bit-wise logical not of integer." (etypecase number (fixnum (lognot (truly-the fixnum number))) (bignum (bignum-logical-not number)))) (macrolet ((frob (name op big-op &optional doc) `(defun ,name (x y) ,@(when doc (list doc)) (number-dispatch ((x integer) (y integer)) (bignum-cross-fixnum ,op ,big-op))))) (frob two-arg-and logand bignum-logical-and) (frob two-arg-ior logior bignum-logical-ior) (frob two-arg-xor logxor bignum-logical-xor) ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must ;; call the generic LOGNOT. (frob two-arg-eqv (lambda (x y) (lognot (logxor x y))) (lambda (x y) (lognot (bignum-logical-xor x y)))) (frob lognand (lambda (x y) (lognot (logand x y))) (lambda (x y) (lognot (bignum-logical-and x y))) "Returns the complement of the AND of integer1 and integer2") (frob lognor (lambda (x y) (lognot (logior x y))) (lambda (x y) (lognot (bignum-logical-ior x y))) "Returns the complement of the OR of integer1 and integer2") (frob logandc1 (lambda (x y) (logand (lognot x) y)) (lambda (x y) (bignum-logical-and (bignum-logical-not x) y)) "Returns the AND of (LOGNOT integer1) and integer2" ) (frob logandc2 (lambda (x y) (logand x (lognot y))) (lambda (x y) (bignum-logical-and x (bignum-logical-not y))) "Returns the AND of integer1 and (LOGNOT integer2)") (frob logorc1 (lambda (x y) (logior (lognot x) y)) (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y)) "Returns the OR of (LOGNOT integer1) and integer2") (frob logorc2 (lambda (x y) (logior x (lognot y))) (lambda (x y) (bignum-logical-ior x (bignum-logical-not y))) "Returns the OR of integer1 and (LOGNOT integer2)") ) (defun logcount (integer) "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits if INTEGER is negative." (etypecase integer (fixnum (logcount (truly-the (integer 0 #.(max most-positive-fixnum (lognot most-negative-fixnum))) (if (minusp (truly-the fixnum integer)) (lognot (truly-the fixnum integer)) integer)))) (bignum (bignum-logcount integer)))) (defun logtest (integer1 integer2) "Predicate which returns T if logand of integer1 and integer2 is not zero." (logtest integer1 integer2)) (defun logbitp (index integer) "Predicate returns T if bit index of integer is a 1. The least significant bit of INTEGER is bit 0." (etypecase integer (fixnum (logbitp index integer)) (bignum (bignum-logbitp index integer)))) (defun ash (integer count) "Shifts integer left by count places preserving sign. - count shifts right." (declare (integer integer count)) (etypecase integer (fixnum (cond ((zerop integer) 0) ((fixnump count) (let ((length (integer-length (truly-the fixnum integer))) (count (truly-the fixnum count))) (declare (fixnum length count)) (cond ((and (plusp count) (> (+ length count) (integer-length most-positive-fixnum))) (bignum-ashift-left (make-small-bignum integer) count)) (t (truly-the fixnum (ash (truly-the fixnum integer) count)))))) ((minusp count) (if (minusp integer) -1 0)) (t (bignum-ashift-left (make-small-bignum integer) count)))) (bignum (if (plusp count) (bignum-ashift-left integer count) (bignum-ashift-right integer (- count)))))) (defun integer-length (integer) "Returns the number of significant bits in the absolute value of integer." (etypecase integer (fixnum (integer-length (truly-the fixnum integer))) (bignum (bignum-integer-length integer)))) ;;;; Byte operations: (defun byte (size position) "Returns a byte specifier which may be used by other byte functions." (byte size position)) (defun byte-size (bytespec) "Returns the size part of the byte specifier bytespec." (byte-size bytespec)) (defun byte-position (bytespec) "Returns the position part of the byte specifier bytespec." (byte-position bytespec)) (defun ldb (bytespec integer) "Extract the specified byte from integer, and right justify result." (ldb bytespec integer)) (defun ldb-test (bytespec integer) "Returns T if any of the specified bits in integer are 1's." (ldb-test bytespec integer)) (defun mask-field (bytespec integer) "Extract the specified byte from integer, but do not right justify result." (mask-field bytespec integer)) (defun dpb (newbyte bytespec integer) "Returns new integer with newbyte in specified position, newbyte is right justified." (dpb newbyte bytespec integer)) (defun deposit-field (newbyte bytespec integer) "Returns new integer with newbyte in specified position, newbyte is not right justified." (deposit-field newbyte bytespec integer)) (defun %ldb (size posn integer) (logand (ash integer (- posn)) (1- (ash 1 size)))) #+nil (defun %ldb (size posn integer) (if (typep integer '(or (signed-byte 32) (unsigned-byte 32))) (logand (ash integer (- posn)) (1- (ash 1 size))) (bignum:bignum-load-byte (byte size posn) integer))) (defun %mask-field (size posn integer) (logand integer (ash (1- (ash 1 size)) posn))) (defun %dpb (newbyte size posn integer) (let ((mask (1- (ash 1 size)))) (logior (logand integer (lognot (ash mask posn))) (ash (logand newbyte mask) posn)))) (defun %deposit-field (newbyte size posn integer) (let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand newbyte mask) (logand integer (lognot mask))))) ;;;; Boole: ;;; The boole function dispaches to any logic operation depending on ;;; the value of a variable. Presently, legal selector values are [0..15]. ;;; boole is open coded for calls with a constant selector. or with calls ;;; using any of the constants declared below. (defconstant boole-clr 0 "Boole function op, makes BOOLE return 0.") (defconstant boole-set 1 "Boole function op, makes BOOLE return -1.") (defconstant boole-1 2 "Boole function op, makes BOOLE return integer1.") (defconstant boole-2 3 "Boole function op, makes BOOLE return integer2.") (defconstant boole-c1 4 "Boole function op, makes BOOLE return complement of integer1.") (defconstant boole-c2 5 "Boole function op, makes BOOLE return complement of integer2.") (defconstant boole-and 6 "Boole function op, makes BOOLE return logand of integer1 and integer2.") (defconstant boole-ior 7 "Boole function op, makes BOOLE return logior of integer1 and integer2.") (defconstant boole-xor 8 "Boole function op, makes BOOLE return logxor of integer1 and integer2.") (defconstant boole-eqv 9 "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") (defconstant boole-nand 10 "Boole function op, makes BOOLE return log nand of integer1 and integer2.") (defconstant boole-nor 11 "Boole function op, makes BOOLE return lognor of integer1 and integer2.") (defconstant boole-andc1 12 "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") (defconstant boole-andc2 13 "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") (defconstant boole-orc1 14 "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") (defconstant boole-orc2 15 "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") (defun boole (op integer1 integer2) "Bit-wise boolean function on two integers. Function chosen by OP: 0 BOOLE-CLR 1 BOOLE-SET 2 BOOLE-1 3 BOOLE-2 4 BOOLE-C1 5 BOOLE-C2 6 BOOLE-AND 7 BOOLE-IOR 8 BOOLE-XOR 9 BOOLE-EQV 10 BOOLE-NAND 11 BOOLE-NOR 12 BOOLE-ANDC1 13 BOOLE-ANDC2 14 BOOLE-ORC1 15 BOOLE-ORC2" (case op (0 (boole 0 integer1 integer2)) (1 (boole 1 integer1 integer2)) (2 (boole 2 integer1 integer2)) (3 (boole 3 integer1 integer2)) (4 (boole 4 integer1 integer2)) (5 (boole 5 integer1 integer2)) (6 (boole 6 integer1 integer2)) (7 (boole 7 integer1 integer2)) (8 (boole 8 integer1 integer2)) (9 (boole 9 integer1 integer2)) (10 (boole 10 integer1 integer2)) (11 (boole 11 integer1 integer2)) (12 (boole 12 integer1 integer2)) (13 (boole 13 integer1 integer2)) (14 (boole 14 integer1 integer2)) (15 (boole 15 integer1 integer2)) (t (error 'type-error :datum op :expected-type '(mod 16))))) ;;;; GCD, LCM: (defun gcd (&rest numbers) "Returns the greatest common divisor of the arguments, which must be integers. Gcd with no arguments is defined to be 0." (cond ((null numbers) 0) ((null (cdr numbers)) (abs (the integer (car numbers)))) (t (do ((gcd (the integer (car numbers)) (gcd gcd (the integer (car rest)))) (rest (cdr numbers) (cdr rest))) ((null rest) gcd) (declare (integer gcd) (list rest)))))) (defun lcm (&rest numbers) "Returns the least common multiple of one or more integers. LCM of no arguments is defined to be 1." (cond ((null numbers) 1) ((null (cdr numbers)) (abs (the integer (car numbers)))) (t (do ((lcm (the integer (car numbers)) (lcm lcm (the integer (car rest)))) (rest (cdr numbers) (cdr rest))) ((null rest) lcm) (declare (integer lcm) (list rest)))))) (defun two-arg-lcm (n m) (declare (integer n m)) (if (or (zerop n) (zerop m)) 0 (let ((m (abs m)) (n (abs n))) (multiple-value-bind (max min) (if (> m n) (values m n) (values n m)) (* (truncate max (gcd n m)) min))))) ;;; TWO-ARG-GCD -- Internal ;;; ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly ;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case ;;; of 0 before the dispatch so that the bignum code doesn't have to worry ;;; about "small bignum" zeros. ;;; (defun two-arg-gcd (u v) (cond ((eql u 0) (abs v)) ((eql v 0) (abs u)) (t (number-dispatch ((u integer) (v integer)) ((fixnum fixnum) (locally (declare (optimize (speed 3) (safety 0))) (do ((k 0 (1+ k)) (u (abs u) (ash u -1)) (v (abs v) (ash v -1))) ((oddp (logior u v)) (do ((temp (if (oddp u) (- v) (ash u -1)) (ash temp -1))) (nil) (declare (fixnum temp)) (when (oddp temp) (if (plusp temp) (setq u temp) (setq v (- temp))) (setq temp (- u v)) (when (zerop temp) (let ((res (ash u k))) (declare (type (signed-byte 31) res) (optimize (inhibit-warnings 3))) (return res)))))) (declare (type (mod 30) k) (type (signed-byte 31) u v))))) ((bignum bignum) (bignum-gcd u v)) ((bignum fixnum) (bignum-gcd u (make-small-bignum v))) ((fixnum bignum) (bignum-gcd (make-small-bignum u) v)))))) ;;; Primep -- Public ;;; (defun primep (x) "Returns T iff X is a positive prime integer." (declare (integer x)) (if (<= x 5) (and (>= x 2) (/= x 4)) (and (not (evenp x)) (not (zerop (rem x 3))) (do ((q 6) (r 1) (inc 2 (logxor inc 6)) ;; 2,4,2,4... (d 5 (+ d inc))) ((or (= r 0) (> d q)) (/= r 0)) (declare (fixnum inc)) (multiple-value-setq (q r) (truncate x d)))))) ;;; ISQRT -- Public ;;; ;;; From discussion on comp.lang.lisp and Akira Kurihara. ;;; (defun isqrt (n) "Returns the root of the nearest integer less than n which is a perfect square." (declare (type unsigned-byte n) (values unsigned-byte)) ;; theoretically (> n 7) ,i.e., n-len-quarter > 0 (if (and (fixnump n) (<= n 24)) (cond ((> n 15) 4) ((> n 8) 3) ((> n 3) 2) ((> n 0) 1) (t 0)) (let* ((n-len-quarter (ash (integer-length n) -2)) (n-half (ash n (- (ash n-len-quarter 1)))) (n-half-isqrt (isqrt n-half)) (init-value (ash (1+ n-half-isqrt) n-len-quarter))) (loop (let ((iterated-value (ash (+ init-value (truncate n init-value)) -1))) (unless (< iterated-value init-value) (return init-value)) (setq init-value iterated-value)))))) ;;;; Random number predicates: (macrolet ((frob (name doc) `(defun ,name (number) ,doc (,name number)))) (frob zerop "Returns T if number = 0, NIL otherwise.") (frob plusp "Returns T if number > 0, NIL otherwise.") (frob minusp "Returns T if number < 0, NIL otherwise.") (frob oddp "Returns T if number is odd, NIL otherwise.") (frob evenp "Returns T if number is even, NIL otherwise.")) ;;;; Modular arithmetic ;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)} (defvar *modular-funs* (make-hash-table :test 'eq)) ;;;; modular functions #+modular-arith #. (collect ((forms)) (flet ((definition (name lambda-list width pattern) `(defun ,name ,lambda-list (flet ((prepare-argument (x) (declare (integer x)) (etypecase x ((unsigned-byte ,width) x) (fixnum (logand x ,pattern)) (bignum (logand x ,pattern))))) (,name ,@(loop for arg in lambda-list collect `(prepare-argument ,arg))))))) (loop for infos being each hash-value of *modular-funs* ;; FIXME: We need to process only "toplevel" functions when (listp infos) do (loop for info in infos for name = (c::modular-fun-info-name info) and width = (c::modular-fun-info-width info) and lambda-list = (c::modular-fun-info-lambda-list info) for pattern = (1- (ash 1 width)) do (forms (definition name lambda-list width pattern))))) `(progn ,@(forms))) ;; Not sure this is 100% right, but the defoptimizer for ash only ;; calls ash-left-mod32 when the COUNT is known to be a (UNSIGNED-BYTE ;; 5), which is what %ASHL wants. #+modular-arith (declaim (inline vm::ash-left-mod32)) #+modular-arith (defun vm::ash-left-mod32 (integer count) (declare (type integer integer) (type (integer 0 31) count)) (bignum::%ashl (ldb (byte 32 0) integer) count)) #+modular-arith (defun vm::ash-mod32 (integer count) (declare (type integer integer) (type (integer -31 31) count)) (if (minusp count) (bignum::%digit-logical-shift-right (ldb (byte 32 0) integer) (- count)) (bignum::%ashl (ldb (byte 32 0) integer) count))) cmucl-21a/src/code/osf1-os.lisp000066400000000000000000000044421260377556400164460ustar00rootroot00000000000000;;; -*- Package: SYSTEM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/osf1-os.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; OS interface functions for CMU CL under Mach. ;;; ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan. ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too. ;;; (in-package "SYSTEM") (use-package "EXTENSIONS") (intl:textdomain "cmucl") (export '(get-system-info get-page-size os-init)) (pushnew :osf1 *features*) (setq *software-type* "OSF1") (defvar *software-version* nil "Version string for supporting software") (defun software-version () "Returns a string describing version of the supporting software." (unless *software-version* (setf *software-version* (string-trim '(#\newline) (with-output-to-string (stream) (run-program "/usr/bin/uname" '("-sr") :output stream))))) *software-version*) ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions ;;; that set up the argument blocks for the server interfaces. (defvar *task-self*) (defun os-init () (setf *software-version* nil)) ;;; GET-SYSTEM-INFO -- Interface ;;; ;;; Return system time, user time and number of page faults. For ;;; page-faults, we add pagein and pageout, since that is a somewhat more ;;; interesting number than the total faults. ;;; (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) (unix:unix-getrusage unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (unless err? (error "Unix system call getrusage failed: ~A." (unix:get-unix-error-msg utime))) (values utime stime majflt))) ;;; GET-PAGE-SIZE -- Interface ;;; ;;; Return the system page size. ;;; (defun get-page-size () (multiple-value-bind (val err) (unix:unix-getpagesize) (unless val (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err))) val)) cmucl-21a/src/code/package.lisp000066400000000000000000002157211260377556400165560ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/package.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Package stuff and stuff like that. ;;; ;;; Re-Written by Rob MacLachlan. Earlier version written by ;;; Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey. ;;; Defpackage by Dan Zigmond. With-Package-Iterator by Blaine Burks. ;;; Defpackage and do-mumble-symbols macros re-written by William Lott. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(package packagep *package* make-package in-package find-package package-name package-nicknames rename-package delete-package package-use-list package-used-by-list package-shadowing-symbols list-all-packages intern find-symbol unintern export unexport import shadowing-import shadow use-package unuse-package find-all-symbols do-symbols with-package-iterator do-external-symbols do-all-symbols apropos apropos-list defpackage)) (in-package "EXTENSIONS") (export '(*keyword-package* *lisp-package* *default-package-use-list* map-apropos package-children package-parent package-lock package-definition-lock without-package-locks unlock-all-packages)) (in-package "KERNEL") (export '(%in-package old-in-package %defpackage)) (in-package "LISP") #+relative-package-names (sys:register-lisp-feature :relative-package-names) (defvar *default-package-use-list* '("COMMON-LISP") "The list of packages to use by default of no :USE argument is supplied to MAKE-PACKAGE or other package creation forms.") ;;; INTERNAL conditions (define-condition simple-package-error (simple-condition package-error) ()) (defstruct (package (:constructor internal-make-package) (:predicate packagep) (:print-function %print-package) (:make-load-form-fun (lambda (package) (values `(package-or-lose ',(package-name package)) nil)))) "Standard structure for the description of a package. Consists of a list of all hash tables, the name of the package, the nicknames of the package, the use-list for the package, the used-by- list, hash- tables for the internal and external symbols, and a list of the shadowing symbols." (tables (list nil)) ; A list of all the hashtables for inherited symbols. ;; ;; The string name of the package. (%name nil :type (or simple-string null)) ;; ;; List of nickname strings. (%nicknames () :type list) ;; ;; List of packages we use. (%use-list () :type list) ;; ;; List of packages that use this package. (%used-by-list () :type list) ;; ;; Hashtables of internal & external symbols. (internal-symbols (required-argument) :type package-hashtable) (external-symbols (required-argument) :type package-hashtable) ;; ;; List of shadowing symbols. (%shadowing-symbols () :type list) ;; ;; Locks for this package. The PACKAGE-LOCK is a lock on the ;; structure of the package, and controls modifications to its list ;; of symbols and its export list. The PACKAGE-DEFINITION-LOCK ;; protects all symbols in the package from being redefined. These ;; are initially disabled, and are enabled by the function ;; PACKAGE-LOCKS-INIT during after-save-initializations. (lock nil :type boolean) (definition-lock nil :type boolean) ;; Documentation string for this package (doc-string nil :type (or simple-string null))) (defun %print-package (s stream d) (declare (ignore d) (stream stream)) (if (package-%name s) (cond (*print-escape* (multiple-value-bind (iu it) (internal-symbol-count s) (multiple-value-bind (eu et) (external-symbol-count s) (print-unreadable-object (s stream) (format stream (intl:gettext "The ~A package, ~D/~D internal, ~D/~D external") (package-%name s) iu it eu et))))) (t (print-unreadable-object (s stream) (format stream (intl:gettext "The ~A package") (package-%name s))))) (print-unreadable-object (s stream :identity t) (format stream (intl:gettext "deleted package"))))) ;;; Can get the name (NIL) of a deleted package. ;;; (defun package-name (x) (package-%name (if (packagep x) x (package-or-lose x)))) (macrolet ((frob (ext real) `(defun ,ext (x) (,real (package-or-lose x))))) (frob package-nicknames package-%nicknames) (frob package-use-list package-%use-list) (frob package-used-by-list package-%used-by-list) (frob package-shadowing-symbols package-%shadowing-symbols)) (defvar *package* () "The current package.") ;;; An equal hashtable from package names to packages. ;;; (defvar *package-names* (make-hash-table :test #'equal)) ;;; Lots of people want the keyword package and Lisp package without a lot ;;; of fuss, so we give them their own variables. ;;; (defvar *lisp-package*) (defvar *keyword-package*) (defvar *enable-package-locked-errors* nil) (define-condition package-locked-error (simple-package-error) () (:report (lambda (condition stream) (format stream (intl:gettext "~&~@") (package-name (package-error-package condition)) (simple-condition-format-control condition) (simple-condition-format-arguments condition))))) (defun package-locks-init () (let ((package-names '("COMMON-LISP" "LISP" "PCL" "CLOS-MOP" "EVAL" "NEW-ASSEM" "DISASSEM" "LOOP" "ANSI-LOOP" "INSPECT" "C" "PROFILE" "WIRE" "BIGNUM" "VM" "FORMAT" "DFIXNUM" "PRETTY-PRINT" "C-CALL" "ALIEN" "ALIEN-INTERNALS" "UNIX" "CONDITIONS" "DEBUG" "DEBUG-INTERNALS" "SYSTEM" "KERNEL" "EXTENSIONS" #+mp "MULTIPROCESSING" "WALKER" "XREF" "STREAM" "INTL"))) (dolist (p package-names) (let ((p (find-package p))) (when p (setf (package-definition-lock p) t) (setf (package-lock p) t)))) (setf *enable-package-locked-errors* t) (push 'redefining-function ext:*setf-fdefinition-hook*)) (values)) (pushnew 'package-locks-init ext:*after-save-initializations*) (defun unlock-all-packages () (dolist (p (list-all-packages)) (setf (package-definition-lock p) nil) (setf (package-lock p) nil))) (defmacro without-package-locks (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) (let ((*enable-package-locked-errors* nil)) ;; Tell the compiler about disabled locks too. This is a ;; workaround for the case of defmacro of a symbol in a locked ;; package. (ext:compiler-let ((*enable-package-locked-errors* nil)) ,@body)))) ;; trap attempts to redefine a function in a locked package, and ;; signal a continuable error. (defun redefining-function (function replacement) (declare (ignore replacement)) (when *enable-package-locked-errors* (multiple-value-bind (valid block-name) (ext:valid-function-name-p function) (declare (ignore valid)) (let ((package (symbol-package block-name))) (when package (when (package-definition-lock package) (when (and (consp function) (member (first function) '(pcl::slot-accessor pcl::method pcl::fast-method pcl::effective-method pcl::ctor))) (return-from redefining-function nil)) (restart-case (error 'package-locked-error :package package :format-control (intl:gettext "redefining function ~A") :format-arguments (list function)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable package's definition-lock, then continue") stream)) (setf (ext:package-definition-lock package) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Disable all package locks, then continue") stream)) (unlock-all-packages))))))))) ;;; This magical variable is T during initialization so Use-Package's of packages ;;; that don't yet exist quietly win. Such packages are thrown onto the list ;;; *Deferred-Use-Packages* so that this can be fixed up later. (defvar *in-package-init* nil) (defvar *deferred-use-packages* nil) (defun stringify-name (name kind) (typecase name (string (string-to-nfc name)) (symbol (symbol-name name)) (base-char (let ((res (make-string 1))) (setf (schar res 0) name) res)) (t (error (intl:gettext "Bogus ~A name: ~S") kind name)))) (defun stringify-names (names kind) (mapcar #'(lambda (name) (stringify-name name kind)) names)) ;;; package-namify -- Internal ;;; ;;; Make a package name into a simple-string. ;;; (defun package-namify (n) (stringify-name n "package")) ;;; package-namestring -- Internal ;;; ;;; Take a package-or-string-or-symbol and return a package name. ;;; (defun package-namestring (thing) (if (packagep thing) (let ((name (package-%name thing))) (or name (error (intl:gettext "Can't do anything to a deleted package: ~S") thing))) (package-namify thing))) ;;; package-name-to-package -- Internal ;;; ;;; Given a package name, a simple-string, do a package name lookup. ;;; (defun package-name-to-package (name) (declare (simple-string name)) (values (gethash name *package-names*))) ;;; package-parent -- Internal. ;;; ;;; Because this function is called via the reader, we want it to be as ;;; fast as possible. ;;; #+relative-package-names (defun package-parent (package-specifier) "Given PACKAGE-SPECIFIER, a package, symbol or string, return the parent package. If there is not a parent, signal an error." (declare (optimize (speed 3))) (flet ((find-last-dot (name) (do* ((len (1- (length name))) (i len (1- i))) ((= i -1) nil) (declare (fixnum len i)) (when (char= #\. (schar name i)) (return i))))) (let* ((child (package-namestring package-specifier)) (dot-position (find-last-dot child))) (cond (dot-position (let ((parent (subseq child 0 dot-position))) (or (package-name-to-package parent) (error 'simple-package-error :name child :format-control (intl:gettext "The parent of ~a does not exist.") :format-arguments (list child))))) (t (error 'simple-package-error :name child :format-control (intl:gettext "There is no parent of ~a.") :format-arguments (list child))))))) ;;; package-children -- Internal. ;;; ;;; While this function is not called via the reader, we do want it to be ;;; fast. ;;; #+relative-package-names (defun package-children (package-specifier &key (recurse t)) "Given PACKAGE-SPECIFIER, a package, symbol or string, return all the packages which are in the hierarchy 'under' the given package. If :recurse is nil, then only return the immediate children of the package." (declare (optimize (speed 3))) (let ((res ()) (parent (package-namestring package-specifier))) (labels ((string-prefix-p (prefix string) (declare (simple-string prefix string)) ;; Return length of `prefix' if `string' starts with `prefix'. ;; We don't use `search' because it does much more than we need ;; and this version is about 10x faster than calling `search'. (let ((prefix-len (length prefix)) (seq-len (length string))) (declare (type index prefix-len seq-len)) (when (>= prefix-len seq-len) (return-from string-prefix-p nil)) (do ((i 0 (1+ i))) ((= i prefix-len) prefix-len) (declare (type index i)) (unless (char= (schar prefix i) (schar string i)) (return nil))))) (test-package (package-name package) (declare (simple-string package-name) (type package package)) (let ((prefix (string-prefix-p (concatenate 'simple-string parent ".") package-name))) (cond (recurse (when prefix (pushnew package res))) (t (when (and prefix (not (find #\. package-name :start prefix))) (pushnew package res))))))) (maphash #'test-package *package-names*) res))) ;;; relative-package-name-to-package -- Internal ;;; ;;; Given a package name, a simple-string, do a relative package name lookup. ;;; It is intended that this function will be called from find-package. ;;; #+relative-package-names (defun relative-package-name-to-package (name) (declare (simple-string name) (optimize (speed 3))) (flet ((relative-to (package name) (declare (type package package) (simple-string name)) (if (string= "" name) package (let ((parent-name (package-%name package))) (unless parent-name (error (intl:gettext "Can't do anything to a deleted package: ~S") package)) (package-name-to-package (concatenate 'simple-string parent-name "." name))))) (find-non-dot (name) (do* ((len (length name)) (i 0 (1+ i))) ((= i len) nil) (declare (type index len i)) (when (char/= #\. (schar name i)) (return i))))) (when (and (plusp (length name)) (char= #\. (schar name 0))) (let* ((last-dot-position (or (find-non-dot name) (length name))) (n-dots last-dot-position) (name (subseq name last-dot-position))) (cond ((= 1 n-dots) ;; relative to current package (relative-to *package* name)) (t ;; relative to our (- n-dots 1)'th parent (let ((package *package*) (tmp nil)) (dotimes (i (1- n-dots)) (declare (fixnum i)) (setq tmp (package-parent package)) (unless tmp (error 'simple-package-error :name (string package) :format-control (intl:gettext "The parent of ~a does not exist.") :format-arguments (list package))) (setq package tmp)) (relative-to package name)))))))) ;;; find-package -- Public ;;; ;;; (defun find-package (name) "Find the package having the specified name." (if (packagep name) name (let ((name (package-namify name))) (or (package-name-to-package name) #+relative-package-names (relative-package-name-to-package name))))) ;;; package-or-lose -- Internal ;;; ;;; Take a package-or-string-or-symbol and return a package. ;;; (defun package-or-lose (thing) (cond ((packagep thing) (unless (package-%name thing) (error (intl:gettext "Can't do anything to a deleted package: ~S") thing)) thing) (t (let ((thing (package-namify thing))) (cond ((package-name-to-package thing)) (t ;; ANSI spec's type-error where this is called. But, ;; but the resulting message is somewhat unclear. ;; May need a new condition type? (with-simple-restart (continue (intl:gettext "Make this package.")) (error 'type-error :datum thing :expected-type 'package)) (make-package thing))))))) ;;; package-listify -- Internal ;;; ;;; Return a list of packages given a package-or-string-or-symbol or ;;; list thereof, or die trying. ;;; (defun package-listify (thing) (let ((res ())) (dolist (thing (if (listp thing) thing (list thing)) res) (push (package-or-lose thing) res)))) ;;;; Package-Hashtables ;;; ;;; Packages are implemented using a special kind of hashtable. It is ;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The ;;; primary purpose of the hash for each entry is to reduce paging by ;;; allowing collisions and misses to be detected without paging in the ;;; symbol and pname for an entry. If the hash for an entry doesn't ;;; match that for the symbol that we are looking for, then we can ;;; go on without touching the symbol, pname, or even hashtable vector. ;;; It turns out that, contrary to my expectations, paging is a very ;;; important consideration the design of the package representation. ;;; Using a similar scheme without the entry hash, the fasloader was ;;; spending more than half its time paging in INTERN. ;;; The hash code also indicates the status of an entry. If it zero, ;;; the entry is unused. If it is one, then it is deleted. ;;; Double-hashing is used for collision resolution. (deftype hash-vector () '(simple-array (unsigned-byte 8) (*))) (defstruct (package-hashtable (:constructor internal-make-package-hashtable ()) (:copier nil) (:print-function (lambda (table stream d) (declare (ignore d) (stream stream)) (format stream (intl:gettext "#") (package-hashtable-size table) (package-hashtable-free table) (package-hashtable-deleted table))))) ;; ;; The g-vector of symbols. (table nil :type (or simple-vector null)) ;; ;; The i-vector of pname hash values. (hash nil :type (or hash-vector null)) ;; ;; The maximum number of entries allowed. (size 0 :type index) ;; ;; The entries that can be made before we have to rehash. (free 0 :type index) ;; ;; The number of deleted entries. (deleted 0 :type index)) ;;; The maximum density we allow in a package hashtable. ;;; (defparameter package-rehash-threshold 3/4) ;;; Entry-Hash -- Internal ;;; ;;; Compute a number from the sxhash of the pname and the length which ;;; must be between 2 and 255. ;;; (defmacro entry-hash (length sxhash) `(the fixnum (+ (the fixnum (rem (the fixnum (logxor ,length ,sxhash (the fixnum (ash ,sxhash -8)) (the fixnum (ash ,sxhash -16)) (the fixnum (ash ,sxhash -19)))) 254)) 2))) ;;; Make-Package-Hashtable -- Internal ;;; ;;; Make a package hashtable having a prime number of entries at least ;;; as great as (/ size package-rehash-threshold). If Res is supplied, ;;; then it is destructively modified to produce the result. This is ;;; useful when changing the size, since there are many pointers to ;;; the hashtable. ;;; (defun make-package-hashtable (size &optional (res (internal-make-package-hashtable))) (do ((n (logior (truncate size package-rehash-threshold) 1) (+ n 2))) ((primep n) (setf (package-hashtable-table res) (make-array n)) (setf (package-hashtable-hash res) (make-array n :element-type '(unsigned-byte 8) :initial-element 0)) (let ((size (truncate (* n package-rehash-threshold)))) (setf (package-hashtable-size res) size) (setf (package-hashtable-free res) size)) (setf (package-hashtable-deleted res) 0) res) (declare (fixnum n)))) ;;; Internal-Symbol-Count, External-Symbols-Count -- Internal ;;; ;;; Return internal and external symbols. Used by Genesis and stuff. ;;; (flet ((stuff (table) (let ((size (the fixnum (- (the fixnum (package-hashtable-size table)) (the fixnum (package-hashtable-deleted table)))))) (declare (fixnum size)) (values (the fixnum (- size (the fixnum (package-hashtable-free table)))) size)))) (defun internal-symbol-count (package) (stuff (package-internal-symbols package))) (defun external-symbol-count (package) (stuff (package-external-symbols package)))) ;;; Add-Symbol -- Internal ;;; ;;; Add a symbol to a package hashtable. The symbol is assumed ;;; not to be present. ;;; (defun add-symbol (table symbol) (let* ((vec (package-hashtable-table table)) (hash (package-hashtable-hash table)) (len (length vec)) (sxhash (%sxhash-simple-string (symbol-name symbol))) (h2 (the fixnum (1+ (the fixnum (rem sxhash (the fixnum (- len 2)))))))) (declare (simple-vector vec) (type (simple-array (unsigned-byte 8)) hash) (fixnum len sxhash h2)) (cond ((zerop (the fixnum (package-hashtable-free table))) (make-package-hashtable (the fixnum (* (the fixnum (package-hashtable-size table)) 2)) table) (add-symbol table symbol) (dotimes (i len) (declare (fixnum i)) (when (> (the fixnum (aref hash i)) 1) (add-symbol table (svref vec i))))) (t (do ((i (rem sxhash len) (rem (+ i h2) len))) ((< (the fixnum (aref hash i)) 2) (if (zerop (the fixnum (aref hash i))) (decf (the fixnum (package-hashtable-free table))) (decf (the fixnum (package-hashtable-deleted table)))) (setf (svref vec i) symbol) (setf (aref hash i) (entry-hash (length (the simple-string (symbol-name symbol))) sxhash))) (declare (fixnum i))))))) ;;; With-Symbol -- Internal ;;; ;;; Find where the symbol named String is stored in Table. Index-Var ;;; is bound to the index, or NIL if it is not present. Symbol-Var ;;; is bound to the symbol. Length and Hash are the length and sxhash ;;; of String. Entry-Hash is the entry-hash of the string and length. ;;; (defmacro with-symbol ((index-var symbol-var table string length sxhash entry-hash) &body forms) (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym)) (name (gensym)) (name-len (gensym)) (ehash (gensym))) `(let* ((,vec (package-hashtable-table ,table)) (,hash (package-hashtable-hash ,table)) (,len (length ,vec)) (,h2 (1+ (the index (rem (the index ,sxhash) (the index (- ,len 2))))))) (declare (type (simple-array (unsigned-byte 8) (*)) ,hash) (simple-vector ,vec) (type index ,len ,h2)) (prog ((,index-var (rem (the index ,sxhash) ,len)) ,symbol-var ,ehash) (declare (type (or index null) ,index-var)) LOOP (setq ,ehash (aref ,hash ,index-var)) (cond ((eql ,ehash ,entry-hash) (setq ,symbol-var (svref ,vec ,index-var)) (let* ((,name (symbol-name ,symbol-var)) (,name-len (length ,name))) (declare (simple-string ,name) (type index ,name-len)) (when (and (= ,name-len ,length) (string= ,string ,name :end1 ,length :end2 ,name-len)) (go DOIT)))) ((zerop ,ehash) (setq ,index-var nil) (go DOIT))) (setq ,index-var (+ ,index-var ,h2)) (when (>= ,index-var ,len) (setq ,index-var (- ,index-var ,len))) (go LOOP) DOIT (return (progn ,@forms)))))) ;;; Nuke-Symbol -- Internal ;;; ;;; Delete the entry for String in Table. The entry must exist. ;;; (defun nuke-symbol (table string) (declare (simple-string string)) (let* ((length (length string)) (hash (%sxhash-simple-string string)) (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (index symbol table string length hash ehash) (setf (aref (package-hashtable-hash table) index) 1) (setf (aref (package-hashtable-table table) index) nil) (incf (package-hashtable-deleted table))))) ;;;; Iteration macros. (defmacro do-symbols ((var &optional (package '*package*) result-form) &parse-body (body decls)) "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* Executes the FORMs at least once for each symbol accessible in the given PACKAGE with VAR bound to the current symbol." (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil (flet ((,flet-name (,var) ,@decls (tagbody ,@body))) (let* ((package (package-or-lose ,package)) (shadows (package-%shadowing-symbols package))) (flet ((iterate-over-hash-table (table ignore) (let ((hash-vec (package-hashtable-hash table)) (sym-vec (package-hashtable-table table))) (declare (type (simple-array (unsigned-byte 8) (*)) hash-vec) (type simple-vector sym-vec)) (dotimes (i (length sym-vec)) (when (>= (aref hash-vec i) 2) (let ((sym (aref sym-vec i))) (declare (inline member)) (unless (member sym ignore :test #'string=) (,flet-name sym)))))))) (iterate-over-hash-table (package-internal-symbols package) nil) (iterate-over-hash-table (package-external-symbols package) nil) (dolist (use (package-%use-list package)) (iterate-over-hash-table (package-external-symbols use) shadows))))) (let ((,var nil)) (declare (ignorable ,var)) ,@decls ,result-form)))) (defmacro do-external-symbols ((var &optional (package '*package*) result-form) &parse-body (body decls)) "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* Executes the FORMs once for each external symbol in the given PACKAGE with VAR bound to the current symbol." (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil (flet ((,flet-name (,var) ,@decls (tagbody ,@body))) (let* ((package (package-or-lose ,package)) (table (package-external-symbols package)) (hash-vec (package-hashtable-hash table)) (sym-vec (package-hashtable-table table))) (declare (type (simple-array (unsigned-byte 8) (*)) hash-vec) (type simple-vector sym-vec)) (dotimes (i (length sym-vec)) (when (>= (aref hash-vec i) 2) (,flet-name (aref sym-vec i)))))) (let ((,var nil)) (declare (ignorable ,var)) ,@decls ,result-form)))) (defmacro do-all-symbols ((var &optional result-form) &parse-body (body decls)) "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* Executes the FORMs once for each symbol in every package with VAR bound to the current symbol." (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil (flet ((,flet-name (,var) ,@decls (tagbody ,@body))) (dolist (package (list-all-packages)) (flet ((iterate-over-hash-table (table) (let ((hash-vec (package-hashtable-hash table)) (sym-vec (package-hashtable-table table))) (declare (type (simple-array (unsigned-byte 8) (*)) hash-vec) (type simple-vector sym-vec)) (dotimes (i (length sym-vec)) (when (>= (aref hash-vec i) 2) (,flet-name (aref sym-vec i))))))) (iterate-over-hash-table (package-internal-symbols package)) (iterate-over-hash-table (package-external-symbols package))))) (let ((,var nil)) (declare (ignorable ,var)) ,@decls ,result-form)))) ;;;; WITH-PACKAGE-ITERATOR (defmacro with-package-iterator ((mname package-list &rest symbol-types) &body body) "Within the lexical scope of the body forms, MNAME is defined via macrolet such that successive invocations of (mname) will return the symbols, one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any of :inherited :external :internal." (let* ((packages (gensym)) (these-packages (gensym)) (ordered-types (let ((res nil)) (dolist (kind '(:inherited :external :internal) res) (when (member kind symbol-types) (push kind res))))) ; Order symbol-types. (counter (gensym)) (kind (gensym)) (hash-vector (gensym)) (vector (gensym)) (package-use-list (gensym)) (init-macro (gensym)) (end-test-macro (gensym)) (real-symbol-p (gensym)) (inherited-symbol-p (gensym)) (BLOCK (gensym))) `(let* ((,these-packages ,package-list) (,packages `,(mapcar #'(lambda (package) (if (packagep package) package (or (find-package package) (error 'simple-package-error :name (string package) :format-control (intl:gettext "~@<~S does not name a package ~:>") :format-arguments (list package))))) (if (consp ,these-packages) ,these-packages (list ,these-packages)))) (,counter nil) (,kind (car ,packages)) (,hash-vector nil) (,vector nil) (,package-use-list nil)) ,(if (member :inherited ordered-types) `(setf ,package-use-list (package-%use-list (car ,packages))) `(declare (ignore ,package-use-list))) (macrolet ((,init-macro (next-kind) (let ((symbols (gensym))) `(progn (setf ,',kind ,next-kind) (setf ,',counter nil) ,(case next-kind (:internal `(let ((,symbols (package-internal-symbols (car ,',packages)))) (when ,symbols (setf ,',vector (package-hashtable-table ,symbols)) (setf ,',hash-vector (package-hashtable-hash ,symbols))))) (:external `(let ((,symbols (package-external-symbols (car ,',packages)))) (when ,symbols (setf ,',vector (package-hashtable-table ,symbols)) (setf ,',hash-vector (package-hashtable-hash ,symbols))))) (:inherited `(let ((,symbols (and ,',package-use-list (package-external-symbols (car ,',package-use-list))))) (when ,symbols (setf ,',vector (package-hashtable-table ,symbols)) (setf ,',hash-vector (package-hashtable-hash ,symbols))))))))) (,end-test-macro (this-kind) `,(let ((next-kind (cadr (member this-kind ',ordered-types)))) (if next-kind `(,',init-macro ,next-kind) `(if (endp (setf ,',packages (cdr ,',packages))) (return-from ,',BLOCK) (,',init-macro ,(car ',ordered-types))))))) (when ,packages ,(when (null symbol-types) (simple-program-error (intl:gettext "Must supply at least one of :internal, ~ :external, or :inherited."))) ,(dolist (symbol symbol-types) (unless (member symbol '(:internal :external :inherited)) (simple-program-error (intl:gettext "~S is not one of :internal, :external, ~ or :inherited.") symbol))) (,init-macro ,(car ordered-types)) (flet ((,real-symbol-p (number) (> number 1))) (macrolet ((,mname () `(block ,',BLOCK (loop (case ,',kind ,@(when (member :internal ',ordered-types) `((:internal (setf ,',counter (position-if #',',real-symbol-p ,',hash-vector :start (if ,',counter (1+ ,',counter) 0))) (if ,',counter (return-from ,',BLOCK (values t (svref ,',vector ,',counter) ,',kind (car ,',packages))) (,',end-test-macro :internal))))) ,@(when (member :external ',ordered-types) `((:external (setf ,',counter (position-if #',',real-symbol-p ,',hash-vector :start (if ,',counter (1+ ,',counter) 0))) (if ,',counter (return-from ,',BLOCK (values t (svref ,',vector ,',counter) ,',kind (car ,',packages))) (,',end-test-macro :external))))) ,@(when (member :inherited ',ordered-types) `((:inherited (flet ((,',inherited-symbol-p (number) (when (,',real-symbol-p number) (let* ((p (position number ,',hash-vector :start (if ,',counter (1+ ,',counter) 0))) (s (svref ,',vector p))) (eql (nth-value 1 (find-symbol (symbol-name s) (car ,',packages))) :inherited))))) (setf ,',counter (position-if #',',inherited-symbol-p ,',hash-vector :start (if ,',counter (1+ ,',counter) 0)))) (cond (,',counter (return-from ,',BLOCK (values t (svref ,',vector ,',counter) ,',kind (car ,',packages)) )) (t (setf ,',package-use-list (cdr ,',package-use-list)) (cond ((endp ,',package-use-list) (setf ,',packages (cdr ,',packages)) (when (endp ,',packages) (return-from ,',BLOCK)) (setf ,',package-use-list (package-%use-list (car ,',packages))) (,',init-macro ,(car ',ordered-types))) (t (,',init-macro :inherited) (setf ,',counter nil))))))))))))) ,@body))))))) ;;;; DEFPACKAGE: (defmacro defpackage (package &rest options) "Defines a new package called PACKAGE. Each of OPTIONS should be one of the following: (:NICKNAMES {package-name}*) (:SIZE ) (:SHADOW {symbol-name}*) (:SHADOWING-IMPORT-FROM {symbol-name}*) (:USE {package-name}*) (:IMPORT-FROM {symbol-name}*) (:INTERN {symbol-name}*) (:EXPORT {symbol-name}*) (:DOCUMENTATION doc-string) All options except :SIZE and :DOCUMENTATION can be used multiple times." (let ((nicknames nil) (size nil) (shadows nil) (shadowing-imports nil) (use nil) (use-p nil) (imports nil) (interns nil) (exports nil) (doc nil)) (dolist (option options) (unless (consp option) (simple-program-error (intl:gettext "Bogus DEFPACKAGE option: ~S") option)) (case (car option) (:nicknames (setf nicknames (stringify-names (cdr option) "package"))) (:size (cond (size (simple-program-error (intl:gettext "Can't specify :SIZE twice."))) ((and (consp (cdr option)) (typep (second option) 'unsigned-byte)) (setf size (second option))) (t (simple-program-error (intl:gettext "Bogus :SIZE, must be a positive integer: ~S") (second option))))) (:shadow (let ((new (stringify-names (cdr option) "symbol"))) (setf shadows (append shadows new)))) (:shadowing-import-from (let ((package-name (stringify-name (second option) "package")) (names (stringify-names (cddr option) "symbol"))) (let ((assoc (assoc package-name shadowing-imports :test #'string=))) (if assoc (setf (cdr assoc) (append (cdr assoc) names)) (setf shadowing-imports (acons package-name names shadowing-imports)))))) (:use (let ((new (stringify-names (cdr option) "package"))) (setf use (delete-duplicates (nconc use new) :test #'string=)) (setf use-p t))) (:import-from (let ((package-name (stringify-name (second option) "package")) (names (stringify-names (cddr option) "symbol"))) (let ((assoc (assoc package-name imports :test #'string=))) (if assoc (setf (cdr assoc) (append (cdr assoc) names)) (setf imports (acons package-name names imports)))))) (:intern (let ((new (stringify-names (cdr option) "symbol"))) (setf interns (append interns new)))) (:export (let ((new (stringify-names (cdr option) "symbol"))) (setf exports (append exports new)))) (:documentation (when doc (simple-program-error (intl:gettext "Can't specify :DOCUMENTATION twice."))) (setf doc (coerce (second option) 'simple-string))) (t (simple-program-error (intl:gettext "Bogus DEFPACKAGE option: ~S") option)))) (check-disjoint `(:intern ,@interns) `(:export ,@exports)) (check-disjoint `(:intern ,@interns) `(:import-from ,@(apply #'append (mapcar #'rest imports))) `(:shadow ,@shadows) `(:shadowing-import-from ,@(apply #'append (mapcar #'rest shadowing-imports)))) `(eval-when (compile load eval) (%defpackage ,(stringify-name package "package") ',nicknames ',size ',shadows ',shadowing-imports ',(if use-p use :default) ',imports ',interns ',exports ',doc)))) (defun check-disjoint (&rest args) ;; Check whether all given arguments specify disjoint sets of symbols. ;; Each argument is of the form (:key . set). (loop for (current-arg . rest-args) on args do (loop with (key1 . set1) = current-arg for (key2 . set2) in rest-args for common = (delete-duplicates (intersection set1 set2 :test #'string=)) unless (null common) do (simple-program-error (intl:gettext "Parameters ~S and ~S must be disjoint ~ but have common elements ~% ~S") key1 key2 common)))) (defun %defpackage (name nicknames size shadows shadowing-imports use imports interns exports doc-string) (declare (type simple-base-string name) (type list nicknames shadows shadowing-imports imports interns exports) (type (or list (member :default)) use) (type (or simple-base-string null) doc-string)) (let ((package (or (find-package name) (progn (when (eq use :default) (setf use *default-package-use-list*)) (make-package name :use nil :internal-symbols (or size 10) :external-symbols (length exports)))))) (unless (string= (the string (package-name package)) name) (error 'simple-package-error :package name :format-control (intl:gettext "~A is a nick-name for the package ~A") :format-arguments (list name (package-name name)))) (enter-new-nicknames package nicknames) ;; Shadows and Shadowing-imports. (let ((old-shadows (package-%shadowing-symbols package))) (shadow shadows package) (dolist (sym-name shadows) (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) (dolist (simports-from shadowing-imports) (let ((other-package (package-or-lose (car simports-from)))) (dolist (sym-name (cdr simports-from)) (let ((sym (find-or-make-symbol sym-name other-package))) (shadowing-import sym package) (setf old-shadows (remove sym old-shadows)))))) (when old-shadows (warn (intl:gettext "~A also shadows the following symbols:~% ~S") name old-shadows))) ;; Use (unless (eq use :default) (let ((old-use-list (package-use-list package)) (new-use-list (mapcar #'package-or-lose use))) (use-package (set-difference new-use-list old-use-list) package) (let ((laterize (set-difference old-use-list new-use-list))) (when laterize (unuse-package laterize package) (warn (intl:gettext "~A previously used the following packages:~% ~S") name laterize))))) ;; Import and Intern. (dolist (sym-name interns) (intern sym-name package)) (dolist (imports-from imports) (let ((other-package (package-or-lose (car imports-from)))) (dolist (sym-name (cdr imports-from)) (import (list (find-or-make-symbol sym-name other-package)) package)))) ;; Exports. (let ((old-exports nil) (exports (mapcar #'(lambda (sym-name) (intern sym-name package)) exports))) (do-external-symbols (sym package) (push sym old-exports)) (export exports package) (let ((diff (set-difference old-exports exports))) (when diff (warn (intl:gettext "~A also exports the following symbols:~% ~S") name diff)))) ;; Documentation (setf (package-doc-string package) doc-string) package)) (defun find-or-make-symbol (name package) (multiple-value-bind (symbol how) (find-symbol name package) (cond (how symbol) (t (with-simple-restart (continue "INTERN it.") (error 'simple-package-error :package package :format-control (intl:gettext "~A does not contain a symbol ~A") :format-arguments (list (package-name package) name))) (intern name package))))) ;;; Enter-New-Nicknames -- Internal ;;; ;;; Enter any new Nicknames for Package into *package-names*. ;;; If there is a conflict then give the user a chance to do ;;; something about it. ;;; (defun enter-new-nicknames (package nicknames) (check-type nicknames list) (dolist (n nicknames) (let* ((n (package-namify n)) (found (package-name-to-package n))) (cond ((not found) (setf (gethash n *package-names*) package) (push n (package-%nicknames package))) ((eq found package)) ((string= (the string (package-%name found)) n) (with-simple-restart (continue (intl:gettext "Ignore this nickname.")) (error 'simple-package-error :package package :format-control (intl:gettext "~S is a package name, so it cannot be a nickname for ~S.") :format-arguments (list n (package-%name package))))) (t (with-simple-restart (continue (intl:gettext "Redefine this nickname.")) (error 'simple-package-error :package package :format-control (intl:gettext "~S is already a nickname for ~S.") :format-arguments (list n (package-%name found)))) (setf (gethash n *package-names*) package) (push n (package-%nicknames package))))))) ;;; Make-Package -- Public ;;; ;;; Check for package name conflicts in name and nicknames, then ;;; make the package. Do a use-package for each thing in the use list ;;; so that checking for conflicting exports among used packages is done. ;;; (defun make-package (name &key (use *default-package-use-list*) nicknames (internal-symbols 10) (external-symbols 10)) "Makes a new package having the specified Name and Nicknames. The package will inherit all external symbols from each package in the use list. :Internal-Symbols and :External-Symbols are estimates for the number of internal and external symbols which will ultimately be present in the package." (when (find-package name) (cerror (intl:gettext "Leave existing package alone.") (intl:gettext "A package named ~S already exists") name)) (let* ((name (package-namify name)) (package (internal-make-package :%name name :internal-symbols (make-package-hashtable internal-symbols) :external-symbols (make-package-hashtable external-symbols)))) (if *in-package-init* (push (list use package) *deferred-use-packages*) (use-package use package)) (enter-new-nicknames package nicknames) (setf (gethash name *package-names*) package))) ;;; Old-In-Package -- Sorta Public. ;;; ;;; Like Make-Package, only different. Should go away someday. ;;; (defun old-in-package (name &rest keys &key nicknames use) "Sets *PACKAGE* to package with given NAME, creating the package if it does not exist. If the package already exists then it is modified to agree with the :USE and :NICKNAMES arguments. Any new nicknames are added without removing any old ones not specified. If any package in the :Use list is not currently used, then it is added to the use list." (let ((package (find-package name))) (cond (package (if *in-package-init* (push (list use package) *deferred-use-packages*) (use-package use package)) (enter-new-nicknames package nicknames) (setq *package* package)) (t (setq *package* (apply #'make-package name keys)))))) ;;; IN-PACKAGE -- public. ;;; (defmacro in-package (package &rest noise) (cond ((or noise (not (or (stringp package) (symbolp package)))) (warn (intl:gettext "Old-style IN-PACKAGE.")) `(old-in-package ,package ,@noise)) (t `(%in-package ',(stringify-name package "package"))))) ;;; (defun %in-package (name) (let ((package (find-package name))) (unless package (with-simple-restart (continue (intl:gettext "Make this package.")) (error 'simple-package-error :package name :format-control (intl:gettext "The package named ~S doesn't exist.") :format-arguments (list name))) (setq package (make-package name))) (setf *package* package))) ;;; Rename-Package -- Public ;;; ;;; Change the name if we can, blast any old nicknames and then ;;; add in any new ones. ;;; (defun rename-package (package name &optional (nicknames ())) "Changes the name and nicknames for a package." (let* ((package (package-or-lose package)) (name (string name)) (found (find-package name))) (unless (or (not found) (eq found package)) (error 'simple-package-error :package name :format-control (intl:gettext "A package named ~S already exists.") :format-arguments (list name))) (remhash (package-%name package) *package-names*) (dolist (n (package-%nicknames package)) (remhash n *package-names*)) (setf (package-%name package) name) (setf (gethash name *package-names*) package) (setf (package-%nicknames package) ()) (enter-new-nicknames package nicknames) package)) ;;; Delete-Package -- Public ;;; (defun delete-package (package-or-name) "Delete the PACKAGE-OR-NAME from the package system data structures." (let ((package (if (packagep package-or-name) package-or-name (find-package package-or-name)))) (cond ((not package) (with-simple-restart (continue (intl:gettext "Return NIL")) (error 'simple-package-error :package package-or-name :format-control (intl:gettext "No package of name ~S.") :format-arguments (list package-or-name))) nil) ((not (package-name package)) nil) (t (let ((use-list (package-used-by-list package))) (when use-list (with-simple-restart (continue (intl:gettext "Remove dependency in other packages.")) (error 'simple-package-error :package package :format-control "Package ~S is used by package(s):~% ~S" :format-arguments (list (package-name package) (mapcar #'package-name use-list)))) (dolist (p use-list) (unuse-package package p)))) (dolist (used (package-use-list package)) (unuse-package used package)) (do-symbols (sym package) (unintern sym package)) (remhash (package-name package) *package-names*) (dolist (nick (package-nicknames package)) (remhash nick *package-names*)) (setf (package-%name package) nil) t)))) ;;; List-All-Packages -- Public ;;; ;;; (defun list-all-packages () "Returns a list of all existing packages." (let ((res ())) (maphash #'(lambda (k v) (declare (ignore k)) (pushnew v res)) *package-names*) res)) ;;; Intern -- Public ;;; ;;; Simple-stringify the name and call intern*. ;;; (defun intern (name &optional package) "Returns a symbol having the specified name, creating it if necessary." (let ((name (string-to-nfc name)) (package (if package (package-or-lose package) *package*))) (declare (type simple-string name)) (intern* name (length name) package))) ;;; Find-Symbol -- Public ;;; ;;; Ditto. ;;; (defun find-symbol (name &optional package) "Returns the symbol NAME in PACKAGE. If such a symbol is found then the second value is :internal, :external or :inherited to indicate how the symbol is accessible. If no symbol is found then both values are NIL." (let ((name (string-to-nfc name))) (declare (simple-string name)) (find-symbol* name (length name) (if package (package-or-lose package) *package*)))) ;;; Intern* -- Internal ;;; ;;; If the symbol doesn't exist then create it, special-casing ;;; the keyword package. ;;; (defun intern* (name length package) (declare (simple-string name)) (multiple-value-bind (symbol where) (find-symbol* name length package) (if where (values symbol where) (progn #+(or) (when *enable-package-locked-errors* (when (ext:package-lock package) (restart-case (error 'package-locked-error :package package :format-control (intl:gettext "interning symbol ~A") :format-arguments (list (subseq name 0 length))) (continue () :report "Ignore the lock and continue") (unlock-package () :report "Unlock package, then continue" (setf (ext:package-lock package) nil)) (unlock-all () :report "Unlock all packages, then continue" (unlock-all-packages))))) (let ((symbol (make-symbol (subseq name 0 length)))) (%set-symbol-package symbol package) (cond ((eq package *keyword-package*) (add-symbol (package-external-symbols package) symbol) (%set-symbol-value symbol symbol)) (t (add-symbol (package-internal-symbols package) symbol))) (values symbol nil)))))) ;;; find-symbol* -- Internal ;;; ;;; Check internal and external symbols, then scan down the list ;;; of hashtables for inherited symbols. When an inherited symbol ;;; is found pull that table to the beginning of the list. ;;; (defun find-symbol* (string length package) (declare (simple-string string) (type index length)) (let* ((hash (%sxhash-simple-substring string length)) (ehash (entry-hash length hash))) (declare (type index hash ehash)) (with-symbol (found symbol (package-internal-symbols package) string length hash ehash) (when found (return-from find-symbol* (values symbol :internal)))) (with-symbol (found symbol (package-external-symbols package) string length hash ehash) (when found (return-from find-symbol* (values symbol :external)))) (let ((head (package-tables package))) (do ((prev head table) (table (cdr head) (cdr table))) ((null table) (values nil nil)) (with-symbol (found symbol (car table) string length hash ehash) (when found (unless (eq prev head) (shiftf (cdr prev) (cdr table) (cdr head) table)) (return-from find-symbol* (values symbol :inherited)))))))) ;;; find-external-symbol -- Internal ;;; ;;; Similar to find-symbol, but only looks for an external symbol. ;;; This is used for fast name-conflict checking in this file and symbol ;;; printing in the printer. ;;; (defun find-external-symbol (string package) (declare (simple-string string)) (let* ((length (length string)) (hash (%sxhash-simple-string string)) (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (found symbol (package-external-symbols package) string length hash ehash) (values symbol found)))) ;;; unintern -- Public ;;; ;;; If we are uninterning a shadowing symbol, then a name conflict can ;;; result, otherwise just nuke the symbol. ;;; (defun unintern (symbol &optional (package *package*)) "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home package, then it is made uninterned." (let* ((package (package-or-lose package)) (name (symbol-name symbol)) (shadowing-symbols (package-%shadowing-symbols package))) (declare (list shadowing-symbols) (simple-string name)) (when *enable-package-locked-errors* (when (ext:package-lock package) (restart-case (error 'package-locked-error :package package :format-control (intl:gettext "uninterning symbol ~A") :format-arguments (list name)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable package's lock then continue") stream)) (setf (ext:package-lock package) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Unlock all packages, then continue") stream)) (unlock-all-packages))))) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. (when (member symbol shadowing-symbols) (let ((cset ())) (dolist (p (package-%use-list package)) (multiple-value-bind (s w) (find-external-symbol name p) (when w (pushnew s cset)))) (when (cdr cset) (loop (cerror (intl:gettext "prompt for a symbol to shadowing-import.") 'simple-package-error :package package :format-control (intl:gettext "Uninterning symbol ~S causes name conflict among these symbols:~%~S") :format-arguments (list symbol cset)) (write-string (intl:gettext "Symbol to shadowing-import: ") *query-io*) (let ((sym (read *query-io*))) (cond ((not (symbolp sym)) (format *query-io* (intl:gettext "~S is not a symbol.") sym)) ((not (member sym cset)) (format *query-io* (intl:gettext "~S is not one of the conflicting symbols.") sym)) (t (shadowing-import sym package) (return-from unintern t))))))) (setf (package-%shadowing-symbols package) (remove symbol shadowing-symbols))) (multiple-value-bind (s w) (find-symbol name package) (cond ((not (eq symbol s)) nil) ((or (eq w :internal) (eq w :external)) (nuke-symbol (if (eq w :internal) (package-internal-symbols package) (package-external-symbols package)) name) (if (eq (symbol-package symbol) package) (%set-symbol-package symbol nil)) t) (t nil))))) ;;; Symbol-Listify -- Internal ;;; ;;; Take a symbol-or-list-of-symbols and return a list, checking types. ;;; (defun symbol-listify (thing) (cond ((listp thing) (dolist (s thing) (unless (symbolp s) (error (intl:gettext "~S is not a symbol.") s))) thing) ((symbolp thing) (list thing)) (t (error (intl:gettext "~S is neither a symbol nor a list of symbols.") thing)))) ;;; Moby-Unintern -- Internal ;;; ;;; Like Unintern, but if symbol is inherited chases down the ;;; package it is inherited from and uninterns it there. Used ;;; for name-conflict resolution. Shadowing symbols are not ;;; uninterned since they do not cause conflicts. ;;; (defun moby-unintern (symbol package) (unless (member symbol (package-%shadowing-symbols package)) (or (unintern symbol package) (let ((name (symbol-name symbol))) (multiple-value-bind (s w) (find-symbol name package) (declare (ignore s)) (when (eq w :inherited) (dolist (q (package-%use-list package)) (multiple-value-bind (u x) (find-external-symbol name q) (declare (ignore u)) (when x (unintern symbol q) (return t)))))))))) ;;; Export -- Public ;;; ;;; Do more stuff. ;;; (defun export (symbols &optional (package *package*)) "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." (let ((package (package-or-lose package)) (syms ())) ;; ;; Punt any symbols that are already external. (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-external-symbol (symbol-name sym) package) (declare (ignore s)) (unless (or w (member sym syms)) (push sym syms)))) ;; ;; Find symbols and packages with conflicts. (let ((used-by (package-%used-by-list package)) (cpackages ()) (cset ())) (dolist (sym syms) (let ((name (symbol-name sym))) (dolist (p used-by) (multiple-value-bind (s w) (find-symbol name p) (when (and w (not (eq s sym)) (not (member s (package-%shadowing-symbols p)))) (pushnew sym cset) (pushnew p cpackages)))))) (when cset (restart-case (error 'simple-package-error :package package :format-control (intl:gettext "Exporting these symbols from the ~A package:~%~S~%~ results in name conflicts with these packages:~%~{~A ~}") :format-arguments (list (package-%name package) cset (mapcar #'package-%name cpackages))) (unintern-conflicting-symbols () :report (lambda (stream) (write-string (intl:gettext "Unintern conflicting symbols.") stream)) (dolist (p cpackages) (dolist (sym cset) (moby-unintern sym p)))) (skip-exporting-these-symbols () :report (lambda (stream) (write-string (intl:gettext "Skip exporting conflicting symbols.") stream)) (setq syms (nset-difference syms cset)))))) ;; ;; Check that all symbols are accessible. If not, ask to import them. (let ((missing ()) (imports ())) (dolist (sym syms) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((not (and w (eq s sym))) (push sym missing)) ((eq w :inherited) (push sym imports))))) (when missing (with-simple-restart (continue (intl:gettext "Import these symbols into the ~A package.") (package-%name package)) (error 'simple-package-error :package package :format-control (intl:gettext "These symbols are not accessible in the ~A package:~%~S") :format-arguments (list (package-%name package) missing))) (import missing package)) (import imports package)) ;; ;; And now, three pages later, we export the suckers. (let ((internal (package-internal-symbols package)) (external (package-external-symbols package))) (dolist (sym syms) (nuke-symbol internal (symbol-name sym)) (add-symbol external sym))) t)) ;;; Unexport -- Public ;;; ;;; Check that all symbols are accessible, then move from external to ;;; internal. ;;; (defun unexport (symbols &optional (package *package*)) "Makes SYMBOLS no longer exported from PACKAGE." (let ((package (package-or-lose package)) (syms ())) (when *enable-package-locked-errors* (when (ext:package-lock package) (restart-case (error 'package-locked-error :package package :format-control (intl:gettext "unexporting symbols ~A") :format-arguments (list symbols)) (continue () :report (lambda (stream) (write-string (intl:gettext "Ignore the lock and continue") stream))) (unlock-package () :report (lambda (stream) (write-string (intl:gettext "Disable package's lock then continue") stream)) (setf (ext:package-lock package) nil)) (unlock-all () :report (lambda (stream) (write-string (intl:gettext "Unlock all packages, then continue") stream)) (unlock-all-packages))))) (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) (error 'simple-package-error :package package :format-control (intl:gettext "~S is not accessible in the ~A package.") :format-arguments (list sym (package-%name package)))) ((eq w :external) (pushnew sym syms))))) (let ((internal (package-internal-symbols package)) (external (package-external-symbols package))) (dolist (sym syms) (add-symbol internal sym) (nuke-symbol external (symbol-name sym)))) t)) ;;; Import -- Public ;;; ;;; Check for name conflic caused by the import and let the user ;;; shadowing-import if there is. ;;; (defun import (symbols &optional (package *package*)) "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol is already accessible then it has no effect. If a name conflict would result from the importation, then a correctable error is signalled." (let ((package (package-or-lose package)) (symbols (symbol-listify symbols)) (syms ()) (cset ())) (dolist (sym symbols) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((not w) (let ((found (member sym syms :test #'string=))) (if found (when (not (eq (car found) sym)) (push sym cset)) (push sym syms)))) ((not (eq s sym)) (push sym cset)) ((eq w :inherited) (push sym syms))))) (when cset (with-simple-restart (continue (intl:gettext "Import these symbols with Shadowing-Import.")) (error 'simple-package-error :package package :format-control (intl:gettext "Importing these symbols into the ~A package ~ causes a name conflict:~%~S") :format-arguments (list (package-%name package) cset)))) ;; ;; Add the new symbols to the internal hashtable. (let ((internal (package-internal-symbols package))) (dolist (sym syms) (add-symbol internal sym))) ;; ;; If any of the symbols are uninterned, make them be owned by Package. (dolist (sym symbols) (unless (symbol-package sym) (%set-symbol-package sym package))) (shadowing-import cset package))) ;;; Shadowing-Import -- Public ;;; ;;; If a conflicting symbol is present, unintern it, otherwise just ;;; stick the symbol in. ;;; (defun shadowing-import (symbols &optional (package *package*)) "Import SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol of the same name is present, then it is uninterned. The symbols are added to the Package-Shadowing-Symbols." (let* ((package (package-or-lose package)) (internal (package-internal-symbols package))) (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (unless (and w (not (eq w :inherited)) (eq s sym)) (when (or (eq w :internal) (eq w :external)) ;; ;; If it was shadowed, we don't want Unintern to flame out... (setf (package-%shadowing-symbols package) (remove s (the list (package-%shadowing-symbols package)))) (unintern s package)) (add-symbol internal sym)) (pushnew sym (package-%shadowing-symbols package))))) t) ;;; Shadow -- Public ;;; ;;; (defun shadow (symbols &optional (package *package*)) "Make an internal symbol in PACKAGE with the same name as each of the specified SYMBOLS, adding the new symbols to the Package-Shadowing-Symbols. If a symbol with the given name is already present in PACKAGE, then the existing symbol is placed in the shadowing symbols list if it is not already present." (let* ((package (package-or-lose package)) (internal (package-internal-symbols package))) (dolist (name (mapcar #'string (if (listp symbols) symbols (list symbols)))) (multiple-value-bind (s w) (find-symbol name package) (when (or (not w) (eq w :inherited)) (setq s (make-symbol name)) (%set-symbol-package s package) (add-symbol internal s)) (pushnew s (package-%shadowing-symbols package))))) t) ;;; Use-Package -- Public ;;; ;;; Do stuff to use a package, with all kinds of fun name-conflict ;;; checking. ;;; (defun use-package (packages-to-use &optional (package *package*)) "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that the external symbols of the used packages are accessible as internal symbols in PACKAGE." (let ((packages (package-listify packages-to-use)) (package (package-or-lose package))) ;; ;; Loop over each package, use'ing one at a time... (dolist (pkg packages) (unless (member pkg (package-%use-list package)) (let ((cset ()) (shadowing-symbols (package-%shadowing-symbols package)) (use-list (package-%use-list package))) ;; ;; If the number of symbols already accessible is less than the ;; number to be inherited then it is faster to run the test the ;; other way. This is particularly valuable in the case of ;; a new package use'ing Lisp. (cond ((< (+ (internal-symbol-count package) (external-symbol-count package) (let ((res 0)) (dolist (p use-list res) (incf res (external-symbol-count p))))) (external-symbol-count pkg)) (do-symbols (sym package) (multiple-value-bind (s w) (find-external-symbol (symbol-name sym) pkg) (when (and w (not (eq s sym)) (not (member sym shadowing-symbols))) (push sym cset)))) (dolist (p use-list) (do-external-symbols (sym p) (multiple-value-bind (s w) (find-external-symbol (symbol-name sym) pkg) (when (and w (not (eq s sym)) (not (member (find-symbol (symbol-name sym) package) shadowing-symbols))) (push sym cset)))))) (t (do-external-symbols (sym pkg) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (when (and w (not (eq s sym)) (not (member s shadowing-symbols))) (push s cset)))))) (when cset (cerror (intl:gettext "Unintern the conflicting symbols in the ~2*~A package.") (intl:gettext "Use'ing package ~A results in name conflicts for these symbols:~%~S") (package-%name pkg) cset (package-%name package)) (dolist (s cset) (moby-unintern s package)))) (push pkg (package-%use-list package)) (push (package-external-symbols pkg) (cdr (package-tables package))) (push package (package-%used-by-list pkg))))) t) ;;; Unuse-Package -- Public ;;; ;;; (defun unuse-package (packages-to-unuse &optional (package *package*)) "Remove PACKAGES-TO-UNUSE from the use list for PACKAGE." (let ((package (package-or-lose package))) (dolist (p (package-listify packages-to-unuse)) (setf (package-%use-list package) (remove p (the list (package-%use-list package)))) (setf (package-tables package) (delete (package-external-symbols p) (the list (package-tables package)))) (setf (package-%used-by-list p) (remove package (the list (package-%used-by-list p))))) t)) ;;; Find-All-Symbols -- Public ;;; ;;; (defun find-all-symbols (string-or-symbol) "Return a list of all symbols in the system having the specified name." (let ((string (string string-or-symbol)) (res ())) (maphash #'(lambda (k v) (declare (ignore k)) (multiple-value-bind (s w) (find-symbol string v) (when w (pushnew s res)))) *package-names*) res)) ;;; Apropos and Apropos-List. (defun briefly-describe-symbol (symbol) (let ((prefix-length nil)) (flet ((print-symbol (&optional kind) (fresh-line) (if prefix-length (dotimes (i prefix-length) (write-char #\Space)) (let ((symbol-string (prin1-to-string symbol))) (write-string symbol-string) (setq prefix-length (length symbol-string)))) (when kind (write-string " [") (write-string kind) (write-string "] ")))) ;; Variable namespace (multiple-value-bind (kind recorded-p) (info variable kind symbol) (when (or (boundp symbol) recorded-p) (print-symbol (ecase kind (:special (intl:gettext "special variable")) (:constant (intl:gettext "constant")) (:global (intl:gettext "undefined variable")) (:macro (intl:gettext "symbol macro")) (:alien (intl:gettext "alien variable")))) (when (boundp symbol) (write-string (intl:gettext "value: ")) (let ((*print-length* (or ext:*describe-print-length* *print-length*)) (*print-level* (or ext:*describe-print-level* *print-level*))) (prin1 (symbol-value symbol)))))) ;; Function namespace (when (fboundp symbol) (cond ((macro-function symbol) (print-symbol (intl:gettext "macro")) (let ((arglist (kernel:%function-arglist (macro-function symbol)))) (when (stringp arglist) (write-string arglist)))) ((special-operator-p symbol) (print-symbol (intl:gettext "special operator")) (let ((arglist (kernel:%function-arglist (symbol-function symbol)))) (when (stringp arglist) (write-string arglist)))) (t (print-symbol (intl:gettext "function")) ;; could do better than this with (kernel:type-specifier ;; (info function type symbol)) when it's a byte-compiled function (let ((arglist (kernel:%function-arglist (symbol-function symbol)))) (when (stringp arglist) (write-string arglist)))))) ;; Class and Type Namespace(s) (cond ((kernel::find-class symbol nil) (print-symbol (intl:gettext "class"))) ((info type kind symbol) (print-symbol (intl:gettext "type")))) ;; Make sure we at least print the symbol itself if we don't know ;; anything else about it: (when (null prefix-length) (print-symbol))))) (defun apropos-search (symbol string) (declare (simple-string string)) (do* ((index 0 (1+ index)) (name (symbol-name symbol)) (length (length string)) (terminus (- (length name) length))) ((> index terminus) nil) (declare (simple-string name) (type index index length) (fixnum terminus)) (if (do ((jndex 0 (1+ jndex)) (kndex index (1+ kndex))) ((= jndex length) t) (declare (fixnum jndex kndex)) (let ((char (schar name kndex))) (unless (char= (schar string jndex) (char-upcase char)) (return nil)))) (return t)))) ;;; MAP-APROPOS -- public (extension). ;;; (defun map-apropos (fun string &optional package external-only) "Call FUN with each symbol that contains STRING. If PACKAGE is supplied then only use symbols present in that package. If EXTERNAL-ONLY is true then only use symbols exported from the specified package." (let ((string (nstring-upcase (string-to-nfc (string string))))) (declare (simple-string string)) (flet ((apropos-in-package (package) (if external-only (do-external-symbols (symbol package) (if (and (eq (symbol-package symbol) package) (apropos-search symbol string)) (funcall fun symbol))) (do-symbols (symbol package) (if (and (eq (symbol-package symbol) package) (apropos-search symbol string)) (funcall fun symbol)))))) (if (null package) (mapc #'apropos-in-package (list-all-packages)) (apropos-in-package (package-or-lose package)))) nil)) ;;; APROPOS -- public. ;;; (defun apropos (string &optional package) "Briefly describe all symbols which contain the specified STRING. If PACKAGE is supplied then only describe symbols present in that package. If EXTERNAL-ONLY is non-NIL then only describe external symbols in the specified package." (map-apropos #'briefly-describe-symbol string package) (values)) ;;; APROPOS-LIST -- public. ;;; (defun apropos-list (string &optional package) "Identical to APROPOS, except that it returns a list of the symbols found instead of describing them." (collect ((result)) (map-apropos #'(lambda (symbol) (result symbol)) string package) (result))) ;;; Initialization. ;;; The cold loader (Genesis) makes the data structure in *initial-symbols*. ;;; We grovel over it, making the specified packages and interning the ;;; symbols. For a description of the format of *initial-symbols* see ;;; the Genesis source. (defvar *initial-symbols*) (defun package-init () (let ((*in-package-init* t)) (dolist (spec *initial-symbols*) (let* ((pkg (apply #'make-package (first spec))) (internal (package-internal-symbols pkg)) (external (package-external-symbols pkg))) ;; ;; Put internal symbols in the internal hashtable and set package. (dolist (symbol (second spec)) (add-symbol internal symbol) (%set-symbol-package symbol pkg)) ;; ;; External symbols same, only go in external table. (dolist (symbol (third spec)) (add-symbol external symbol) (%set-symbol-package symbol pkg)) ;; ;; Don't set package for Imported symbols. (dolist (symbol (fourth spec)) (add-symbol internal symbol)) (dolist (symbol (fifth spec)) (add-symbol external symbol)) ;; ;; Put shadowing symbols in the shadowing symbols list. (setf (package-%shadowing-symbols pkg) (sixth spec)))) (makunbound '*initial-symbols*) ; So it gets GC'ed. ;; Make some other packages that should be around in the cold load: (make-package "COMMON-LISP-USER" :nicknames '("CL-USER")) ;; Now do the *deferred-use-packages*: (dolist (args *deferred-use-packages*) (apply #'use-package args)) (makunbound '*deferred-use-packages*) (setq *lisp-package* (find-package "LISP")) (setq *keyword-package* (find-package "KEYWORD")) ;; For the kernel core image wizards, set the package to *Lisp-Package*. (setq *package* *lisp-package*))) cmucl-21a/src/code/parse-time.lisp000066400000000000000000000701561260377556400172320ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*- ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/parse-time.lisp $") ;;; ;;; ********************************************************************** ;;; Parsing routines for time and date strings. Parse-time returns the ;;; universal time integer for the time and/or date given in the string. ;;; Written by Jim Healy, June 1987. ;;; ********************************************************************** (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export 'parse-time) (defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`)) (defconstant time-dividers '(#\: #\.)) (defconstant date-dividers '(#\\ #\/ #\-)) (defconstant date-time-dividers '(#\T #\t)) (defvar *error-on-mismatch* nil "If t, an error will be signalled if parse-time is unable to determine the time/date format of the string.") ;;; Set up hash tables for month, weekday, zone, and special strings. ;;; Provides quick, easy access to associated information for these items. ;;; Hashlist takes an association list and hashes each pair into the ;;; specified tables using the car of the pair as the key and the cdr as ;;; the data object. (defmacro hashlist (list table) `(dolist (item ,list) (setf (gethash (car item) ,table) (cdr item)))) (defparameter weekday-table-size 23) (defparameter month-table-size 31) (defparameter zone-table-size 11) (defparameter special-table-size 11) (defvar *weekday-strings* (make-hash-table :test #'equal :size weekday-table-size)) (defvar *month-strings* (make-hash-table :test #'equal :size month-table-size)) (defvar *zone-strings* (make-hash-table :test #'equal :size zone-table-size)) (defvar *special-strings* (make-hash-table :test #'equal :size special-table-size)) ;;; Load-time creation of the hash tables. (hashlist '(("monday" . 0) ("mon" . 0) ("tuesday" . 1) ("tues" . 1) ("tue" . 1) ("wednesday" . 2) ("wednes" . 2) ("wed" . 2) ("thursday" . 3) ("thurs" . 3) ("thu" . 3) ("friday" . 4) ("fri" . 4) ("saturday" . 5) ("sat" . 5) ("sunday" . 6) ("sun" . 6)) *weekday-strings*) (hashlist '(("january" . 1) ("jan" . 1) ("february" . 2) ("feb" . 2) ("march" . 3) ("mar" . 3) ("april" . 4) ("apr" . 4) ("may" . 5) ("june" . 6) ("jun" . 6) ("july" . 7) ("jul" . 7) ("august" . 8) ("aug" . 8) ("september" . 9) ("sept" . 9) ("sep" . 9) ("october" . 10) ("oct" . 10) ("november" . 11) ("nov" . 11) ("december" . 12) ("dec" . 12)) *month-strings*) (hashlist '(("gmt" . 0) ("est" . 5) ("edt" . 4) ("cst" . 6) ("cdt" . 5) ("mst" . 7) ("mdt" . 6) ("pst" . 8) ("pdt" . 7) ("utc" . 0) ("z" . 0)) *zone-strings*) (hashlist '(("yesterday" . yesterday) ("today" . today) ("tomorrow" . tomorrow) ("now" . now)) *special-strings*) ;;; Time/date format patterns are specified as lists of symbols repre- ;;; senting the elements. Optional elements can be specified by ;;; enclosing them in parentheses. Note that the order in which the ;;; patterns are specified below determines the order of search. ;;; Choices of pattern symbols are: secondp, minute, hour, day, month, ;;; year, time-divider, date-divider, am-pm, zone, izone, weekday, ;;; noon-midn, and any special symbol. (defparameter *default-date-time-patterns* '( ;; Date formats. ((weekday) month (date-divider) day (date-divider) year (noon-midn)) ((weekday) day (date-divider) month (date-divider) year (noon-midn)) ((weekday) month (date-divider) day (noon-midn)) (year (date-divider) month (date-divider) day (noon-midn)) (month (date-divider) year (noon-midn)) (year (date-divider) month (noon-midn)) ((noon-midn) (weekday) month (date-divider) day (date-divider) year) ((noon-midn) (weekday) day (date-divider) month (date-divider) year) ((noon-midn) (weekday) month (date-divider) day) ((noon-midn) year (date-divider) month (date-divider) day) ((noon-midn) month (date-divider) year) ((noon-midn) year (date-divider) month) ;; Time formats. (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (noon-midn) (hour (noon-midn)) ;; Time/date combined formats. ;; This pattern is produced by ctime/asctime (weekday month day hour (time-divider) minute (time-divider) secondp year) ((weekday) month (date-divider) day (date-divider) year hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) ((weekday) day (date-divider) month (date-divider) year hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) ((weekday) month (date-divider) day hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (year (date-divider) month (date-divider) day hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (year (date-divider) month (date-divider) day (date-time-divider) hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (month (date-divider) year hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (year (date-divider) month hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone)) (year date-divider month date-divider day hour time-divider minute time-divider secondp time-divider microsecond (zone)) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) (weekday) month (date-divider) day (date-divider) year) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) (weekday) day (date-divider) month (date-divider) year) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) (weekday) month (date-divider) day) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) year (date-divider) month (date-divider) day) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) month (date-divider) year) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) year (date-divider) month) ;; Weird, non-standard formats. (weekday month day hour (time-divider) minute (time-divider) secondp (am-pm) (zone) year) ((weekday) day (date-divider) month (date-divider) year hour (time-divider) minute (time-divider) (secondp) (am-pm) (date-divider) (zone)) ((weekday) month (date-divider) day (date-divider) year hour (time-divider) minute (time-divider) (secondp) (am-pm) (date-divider) (zone)) ;; Special-string formats. (now (yesterday)) ((yesterday) now) (now (today)) ((today) now) (now (tomorrow)) ((tomorrow) now) (yesterday (noon-midn)) ((noon-midn) yesterday) (today (noon-midn)) ((noon-midn) today) (tomorrow (noon-midn)) ((noon-midn) tomorrow) )) ;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C. (defparameter *http-date-time-patterns* '( ;; RFC1123/RFC822 and RFC850. ((weekday) day (date-divider) month (date-divider) year hour time-divider minute (time-divider) (secondp) izone) ((weekday) day (date-divider) month (date-divider) year hour time-divider minute (time-divider) (secondp) (zone)) ;; ANSI-C. ((weekday) month day hour time-divider minute (time-divider) (secondp) year))) ;;; The decoded-time structure holds the time/date values which are ;;; eventually passed to 'encode-universal-time' after parsing. ;;; Note: Currently PARSE-TIME defaults the day of the week to -1 (invalid) so ;;; the CHECK-WEEKDAY function can set it correctly. This is less than ;;; optimal. (defstruct decoded-time (second 0 :type integer) ; Value between 0 and 59. (minute 0 :type integer) ; Value between 0 and 59. (hour 0 :type integer) ; Value between 0 and 23. (day 1 :type integer) ; Value between 1 and 31. (month 1 :type integer) ; Value between 1 and 12. (year 1900 :type integer) ; Value above 1899 or between 0 and 99. (zone 0 :type rational) ; Value between -24 and 24 inclusive. (dotw 0 :type integer)) ; Value between 0 and 6. -1 if invalid. ;;; Make-default-time returns a decoded-time structure with the default ;;; time values already set. The default time is currently 00:00 on ;;; the current day, current month, current year, and current time-zone. (defun make-default-time (def-sec def-min def-hour def-day def-mon def-year def-zone def-dotw) (let ((default-time (make-decoded-time))) (multiple-value-bind (sec min hour day mon year dotw dst zone) (get-decoded-time) (declare (ignore dst)) (if def-sec (if (eq def-sec :current) (setf (decoded-time-second default-time) sec) (setf (decoded-time-second default-time) def-sec)) (setf (decoded-time-second default-time) 0)) (if def-min (if (eq def-min :current) (setf (decoded-time-minute default-time) min) (setf (decoded-time-minute default-time) def-min)) (setf (decoded-time-minute default-time) 0)) (if def-hour (if (eq def-hour :current) (setf (decoded-time-hour default-time) hour) (setf (decoded-time-hour default-time) def-hour)) (setf (decoded-time-hour default-time) 0)) (if def-day (if (eq def-day :current) (setf (decoded-time-day default-time) day) (setf (decoded-time-day default-time) def-day)) (setf (decoded-time-day default-time) day)) (if def-mon (if (eq def-mon :current) (setf (decoded-time-month default-time) mon) (setf (decoded-time-month default-time) def-mon)) (setf (decoded-time-month default-time) mon)) (if def-year (if (eq def-year :current) (setf (decoded-time-year default-time) year) (setf (decoded-time-year default-time) def-year)) (setf (decoded-time-year default-time) year)) (if def-zone (if (eq def-zone :current) (setf (decoded-time-zone default-time) zone) (setf (decoded-time-zone default-time) def-zone)) (setf (decoded-time-zone default-time) zone)) (if def-dotw (if (eq def-dotw :current) (setf (decoded-time-dotw default-time) dotw) (setf (decoded-time-dotw default-time) def-dotw)) (setf (decoded-time-dotw default-time) dotw)) default-time))) ;;; Converts the values in the decoded-time structure to universal time ;;; by calling encode-universal-time. ;;; If zone is in numerical form, tweeks it appropriately. (defun convert-to-unitime (parsed-values) (let ((zone (decoded-time-zone parsed-values))) (encode-universal-time (decoded-time-second parsed-values) (decoded-time-minute parsed-values) (decoded-time-hour parsed-values) (decoded-time-day parsed-values) (decoded-time-month parsed-values) (decoded-time-year parsed-values) (if (or (> zone 24) (< zone -24)) (let ((new-zone (/ zone 100))) (cond ((minusp new-zone) (- new-zone)) ((plusp new-zone) (- 24 new-zone)) ;; must be zero (GMT) (t new-zone))) zone)))) ;;; Sets the current values for the time and/or date parts of the ;;; decoded time structure. (defun set-current-value (values-structure &key (time nil) (date nil) (zone nil)) (multiple-value-bind (sec min hour day mon year dotw dst tz) (get-decoded-time) (declare (ignore dst)) (when time (setf (decoded-time-second values-structure) sec) (setf (decoded-time-minute values-structure) min) (setf (decoded-time-hour values-structure) hour)) (when date (setf (decoded-time-day values-structure) day) (setf (decoded-time-month values-structure) mon) (setf (decoded-time-year values-structure) year) (setf (decoded-time-dotw values-structure) dotw)) (when zone (setf (decoded-time-zone values-structure) tz)))) ;;; Special function definitions. To define a special substring, add ;;; a dotted pair consisting of the substring and a symbol in the ;;; *special-strings* hashlist statement above. Then define a function ;;; here which takes one argument- the decoded time structure- and ;;; sets the values of the structure to whatever is necessary. Also, ;;; add a some patterns to the patterns list using whatever combinations ;;; of special and pre-existing symbols desired. (defun yesterday (parsed-values) (set-current-value parsed-values :date t :zone t) (setf (decoded-time-day parsed-values) (1- (decoded-time-day parsed-values)))) (defun today (parsed-values) (set-current-value parsed-values :date t :zone t)) (defun tomorrow (parsed-values) (set-current-value parsed-values :date t :zone t) (setf (decoded-time-day parsed-values) (1+ (decoded-time-day parsed-values)))) (defun now (parsed-values) (set-current-value parsed-values :time t)) ;;; Predicates for symbols. Each symbol has a corresponding function ;;; defined here which is applied to a part of the datum to see if ;;; it matches the qualifications. (defun am-pm (string) (and (simple-string-p string) (cond ((string= string "am") 'am) ((string= string "pm") 'pm) (t nil)))) (defun noon-midn (string) (and (simple-string-p string) (cond ((string= string "noon") 'noon) ((string= string "midnight") 'midn) (t nil)))) (defun weekday (string) (and (simple-string-p string) (gethash string *weekday-strings*))) (defun month (thing) (or (and (simple-string-p thing) (gethash thing *month-strings*)) (and (integerp thing) (<= 1 thing 12)))) (defun zone (thing) (or (and (simple-string-p thing) (gethash thing *zone-strings*)) (if (integerp thing) (let ((zone (/ thing 100))) (and (integerp zone) (<= -24 zone 24)))))) ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. (defun izone (thing) (if (integerp thing) (multiple-value-bind (hours mins) (truncate thing 100) (and (<= -24 hours 24) (<= -59 mins 59))))) (defun special-string-p (string) (and (simple-string-p string) (gethash string *special-strings*))) (defun microsecond (number) (integerp number)) (defun secondp (number) (and (integerp number) (<= 0 number 59))) (defun minute (number) (and (integerp number) (<= 0 number 59))) (defun hour (number) (and (integerp number) (<= 0 number 23))) (defun day (number) (and (integerp number) (<= 1 number 31))) (defun year (number) (and (integerp number) (or (<= 0 number 99) (<= 1900 number)))) (defun time-divider (character) (and (characterp character) (member character time-dividers :test #'char=))) (defun date-divider (character) (and (characterp character) (member character date-dividers :test #'char=))) (defun date-time-divider (character) (and (characterp character) (member character date-time-dividers :test #'char=))) ;;; Match-substring takes a string argument and tries to match it with ;;; the strings in one of the four hash tables: *weekday-strings*, *month- ;;; strings*, *zone-strings*, *special-strings*. It returns a specific ;;; keyword and/or the object it finds in the hash table. If no match ;;; is made then it immediately signals an error. (defun match-substring (substring) (let ((substring (nstring-downcase substring))) (or (let ((test-value (month substring))) (if test-value (cons 'month test-value))) (let ((test-value (weekday substring))) (if test-value (cons 'weekday test-value))) (let ((test-value (am-pm substring))) (if test-value (cons 'am-pm test-value))) (let ((test-value (noon-midn substring))) (if test-value (cons 'noon-midn test-value))) (let ((test-value (zone substring))) (if test-value (cons 'zone test-value))) (let ((test-value (special-string-p substring))) (if test-value (cons 'special test-value))) (if *error-on-mismatch* (error (intl:gettext "\"~A\" is not a recognized word or abbreviation.") substring) (return-from match-substring nil))))) ;;; Decompose-string takes the time/date string and decomposes it into a ;;; list of alphabetic substrings, numbers, and special divider characters. ;;; It matches whatever strings it can and replaces them with a dotted pair ;;; containing a symbol and value. (defun decompose-string (string &key (start 0) (end (length string)) (radix 10)) (do ((string-index start) (next-negative nil) (parts-list nil)) ((eq string-index end) (nreverse parts-list)) (let ((next-char (char string string-index)) (prev-char (if (= string-index start) nil (char string (1- string-index))))) (cond ((and (/= string-index start) (member next-char date-time-dividers :test #'char=)) ;; A date-time-divider can't be at the start of the string. (push (cons 'date-time-divider next-char) parts-list) (incf string-index)) ((alpha-char-p next-char) ;; Alphabetic character - scan to the end of the substring. (do ((scan-index (1+ string-index) (1+ scan-index))) ((or (eq scan-index end) (not (alpha-char-p (char string scan-index)))) (let ((match-symbol (match-substring (subseq string string-index scan-index)))) (if match-symbol (push match-symbol parts-list) (return-from decompose-string nil))) (setf string-index scan-index)))) ((digit-char-p next-char radix) ;; Numeric digit - convert digit-string to a decimal value. (do ((scan-index string-index (1+ scan-index)) (numeric-value 0 (+ (* numeric-value radix) (digit-char-p (char string scan-index) radix)))) ((or (eq scan-index end) (not (digit-char-p (char string scan-index) radix))) ;; If next-negative is t, set the numeric value to it's ;; opposite and reset next-negative to nil. (when next-negative (setf next-negative nil) (setf numeric-value (- numeric-value))) (push numeric-value parts-list) (setf string-index scan-index)))) ((and (member next-char '(#\+ #\-) :test #'char=) (or (not prev-char) (member prev-char whitespace-chars :test #'char=))) ;; If we see a minus or plus sign before a number, but ;; not after one, it is not a date divider, but a offset ;; from GMT, so set next-negative to t if minus and continue. (setq next-negative (char= next-char #\-)) (incf string-index)) ((member next-char time-dividers :test #'char=) ;; Time-divider - add it to the parts-list with symbol. (push (cons 'time-divider next-char) parts-list) (incf string-index)) ((member next-char date-dividers :test #'char=) ;; Date-divider - add it to the parts-list with symbol. (push (cons 'date-divider next-char) parts-list) (incf string-index)) ((member next-char whitespace-chars :test #'char=) ;; Whitespace character - ignore it completely. (incf string-index)) ((char= next-char #\() ;; Parenthesized string - scan to the end and ignore it. (do ((scan-index string-index (1+ scan-index))) ((or (eq scan-index end) (char= (char string scan-index) #\))) (setf string-index (1+ scan-index))))) (t ;; Unrecognized character - barf voraciously. (if *error-on-mismatch* (error 'simple-error :format-control (intl:gettext "Can't parse time/date string.~%>>> ~A~ ~%~VT^-- Bogus character encountered here.") :format-arguments (list string (+ string-index 4))) (return-from decompose-string nil))))))) ;;; Match-pattern-element tries to match a pattern element with a datum ;;; element and returns the symbol associated with the datum element if ;;; successful. Otherwise nil is returned. (defun match-pattern-element (pattern-element datum-element) (cond ((listp datum-element) (let ((datum-type (if (eq (car datum-element) 'special) (cdr datum-element) (car datum-element)))) (if (eq datum-type pattern-element) datum-element))) ((funcall pattern-element datum-element) (cons pattern-element datum-element)) (t nil))) ;;; Match-pattern matches a pattern against a datum, returning the ;;; pattern if successful and nil otherwise. (defun match-pattern (pattern datum datum-length) (if (>= (length pattern) datum-length) (let ((form-list nil)) (do ((pattern pattern (cdr pattern)) (datum datum (cdr datum))) ((or (null pattern) (null datum)) (cond ((and (null pattern) (null datum)) (nreverse form-list)) ((null pattern) nil) ((null datum) (dolist (element pattern (nreverse form-list)) (if (not (listp element)) (return nil)))))) (let* ((pattern-element (car pattern)) (datum-element (car datum)) (optional (listp pattern-element)) (matching (match-pattern-element (if optional (car pattern-element) pattern-element) datum-element))) (cond (matching (let ((form-type (car matching))) (unless (or (eq form-type 'time-divider) (eq form-type 'date-divider)) (push matching form-list)))) (optional (push datum-element datum)) (t (return-from match-pattern nil)))))))) ;;; Deal-with-noon-midn sets the decoded-time values to either noon ;;; or midnight depending on the argument form-value. Form-value ;;; can be either 'noon or 'midn. (defun deal-with-noon-midn (form-value parsed-values) (cond ((eq form-value 'noon) (setf (decoded-time-hour parsed-values) 12)) ((eq form-value 'midn) (setf (decoded-time-hour parsed-values) 0)) (t (error (intl:gettext "Unrecognized symbol: ~A") form-value))) (setf (decoded-time-minute parsed-values) 0) (setf (decoded-time-second parsed-values) 0)) ;;; Deal-with-am-pm sets the decoded-time values to be in the am ;;; or pm depending on the argument form-value. Form-value can ;;; be either 'am or 'pm. (defun deal-with-am-pm (form-value parsed-values) (let ((hour (decoded-time-hour parsed-values))) (cond ((eq form-value 'am) (cond ((eq hour 12) (setf (decoded-time-hour parsed-values) 0)) ((not (<= 0 hour 12)) (if *error-on-mismatch* (error (intl:gettext "~D is not an AM hour, dummy.") hour))))) ((eq form-value 'pm) (if (<= 0 hour 11) (setf (decoded-time-hour parsed-values) (mod (+ hour 12) 24)))) (t (error (intl:gettext "~A isn't AM/PM - this shouldn't happen.") form-value))))) ;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes. (defun deal-with-izone (form-value parsed-values) (multiple-value-bind (hours mins) (truncate form-value 100) (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60)))))) (defun check-days-per-month (parsed-values) (let ((ok (cond ((= (decoded-time-month parsed-values) 2) ;; February only has 28 days, except for leap years (flet ((leap-year-p (y) ;; Leap years are years divisible by 4. Except if ;; it's divisible by 100, in which case, only if ;; it's divisible by 400. (let ((div-100 (mod y 100)) (div-4 (mod y 4))) (if (zerop div-100) (zerop (mod y 400)) (zerop div-4))))) (<= (decoded-time-day parsed-values) (if (leap-year-p (decoded-time-year parsed-values)) 29 28)))) ((member (decoded-time-month parsed-values) '(4 6 9 11)) ;; These months only have 30 days (<= (decoded-time-day parsed-values) 30)) (t t)))) (unless ok (error (intl:gettext "Invalid number of days (~D) for month ~D in ~D") (decoded-time-day parsed-values) (decoded-time-month parsed-values) (decoded-time-year parsed-values))))) (defun weekday-from-gregorian (month day year) ;; TYPE gregorian-date -> weekday. adapted from reingold. 0 = sunday. (mod (+ 0 ; Days before start of calendar (* 365 (1- year)) ; Ordinary days since epoch (floor (1- year) 4) ; Julian leap days since epoch... (- ; ...minus century years since epoch... (floor (1- year) 100)) (floor ; ...plus years since epoch divisible... (1- year) 400) ; ...by 400. (floor ; Days in prior months this year... (- (* 367 month) 362) ; ...assuming 30-day Feb 12) (if (<= month 2) ; Correct for 28- or 29-day Feb 0 (if (and (= (mod year 4) 0) ; gregorian-leap-year (not (member (mod year 400) (list 100 200 300)))) -1 -2)) day) 7)) (defun check-weekday (parsed-values) (let ((dotw (mod (1- (weekday-from-gregorian (decoded-time-month parsed-values) (decoded-time-day parsed-values) (decoded-time-year parsed-values))) 7))) (flet ((lookup-name (day) (maphash #'(lambda (k v) (when (= v day) (return-from lookup-name k))) *weekday-strings*))) (if (< (decoded-time-dotw parsed-values) 0) (setf (decoded-time-dotw parsed-values) dotw) (unless (= dotw (decoded-time-dotw parsed-values)) (cerror (intl:gettext "Ignore.") (intl:gettext "Specified day (~@(~A~)) doesn't match actual day (~@(~A~))") (lookup-name (decoded-time-dotw parsed-values)) (lookup-name dotw))))))) ;;; Set-time-values uses the association list of symbols and values ;;; to set the time in the decoded-time structure. (defun set-time-values (string-form parsed-values) (dolist (form-part string-form t) (let ((form-type (car form-part)) (form-value (cdr form-part))) (case form-type (microsecond 0) (secondp (setf (decoded-time-second parsed-values) form-value)) (minute (setf (decoded-time-minute parsed-values) form-value)) (hour (setf (decoded-time-hour parsed-values) form-value)) (day (setf (decoded-time-day parsed-values) form-value)) (month (setf (decoded-time-month parsed-values) form-value)) (year (setf (decoded-time-year parsed-values) form-value)) (zone (setf (decoded-time-zone parsed-values) form-value)) (izone (deal-with-izone form-value parsed-values)) (weekday (setf (decoded-time-dotw parsed-values) form-value)) (am-pm (deal-with-am-pm form-value parsed-values)) (noon-midn (deal-with-noon-midn form-value parsed-values)) (date-time-divider 0) (special (funcall form-value parsed-values)) (t (error (intl:gettext "Unrecognized symbol in form list: ~A.") form-type))))) ;; Some simple sanity checks, like does the given month have that ;; many days? Is it a leap year? (check-days-per-month parsed-values) (check-weekday parsed-values)) (defun parse-time (time-string &key (start 0) (end (length time-string)) (error-on-mismatch nil) (patterns *default-date-time-patterns*) (default-seconds nil) (default-minutes nil) (default-hours nil) (default-day nil) (default-month nil) (default-year nil) (default-zone nil) (default-weekday -1)) "Tries very hard to make sense out of the argument time-string and returns a single integer representing the universal time if successful. If not, it returns nil. If the :error-on-mismatch keyword is true, parse-time will signal an error instead of returning nil. Default values for each part of the time/date can be specified by the appropriate :default- keyword. These keywords can be given a numeric value or the keyword :current to set them to the current value. The default-default values are 00:00:00 on the current date, current time-zone." (setq *error-on-mismatch* error-on-mismatch) (let* ((string-parts (decompose-string time-string :start start :end end)) (parts-length (length string-parts)) (string-form (dolist (pattern patterns) (let ((match-result (match-pattern pattern string-parts parts-length))) (if match-result (return match-result)))))) (if string-form (let ((parsed-values (make-default-time default-seconds default-minutes default-hours default-day default-month default-year default-zone default-weekday))) (set-time-values string-form parsed-values) (convert-to-unitime parsed-values)) (if *error-on-mismatch* (error (intl:gettext "\"~A\" is not a recognized time/date format.") time-string) nil)))) cmucl-21a/src/code/pathname.lisp000066400000000000000000002202131260377556400167500ustar00rootroot00000000000000;;; -*- Package: LISP -*- ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pathname.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Machine/filesystem independent pathname functions for CMU Common Lisp. ;;; ;;; Written by William Lott, Paul Gleichauf and Rob MacLachlan. ;;; Earlier version written by Jim Large and Rob MacLachlan ;;; ;;; ********************************************************************** (in-package "LISP") (intl:textdomain "cmucl") (export '(pathname pathnamep logical-pathname parse-namestring merge-pathnames make-pathname pathname-host pathname-device pathname-directory pathname-name pathname-type pathname-version namestring file-namestring directory-namestring host-namestring enough-namestring wild-pathname-p pathname-match-p translate-pathname translate-logical-pathname logical-pathname-translations load-logical-pathname-translations *default-pathname-defaults*)) (in-package "EXTENSIONS") (export '(search-list search-list-defined-p clear-search-list enumerate-search-list *autoload-translations*)) (in-package "LISP") (defvar *autoload-translations* nil "When non-nil, attempt to load \"library:.translations\" to resolve an otherwise undefined logical host.") ;;;; HOST structures ;;; The host structure holds the functions that both parse the pathname ;;; information into sturcture slot entries, and after translation the inverse ;;; (unparse) functions. ;;; (defstruct (host (:print-function %print-host)) (parse (required-argument) :type function) (unparse (required-argument) :type function) (unparse-host (required-argument) :type function) (unparse-directory (required-argument) :type function) (unparse-file (required-argument) :type function) (unparse-enough (required-argument) :type function) (customary-case (required-argument) :type (member :upper :lower))) ;;; %PRINT-HOST -- Internal ;;; (defun %print-host (host stream depth) (declare (ignore depth)) (print-unreadable-object (host stream :type t))) (defun %print-logical-host (host stream depth) (declare (ignore depth)) (print-unreadable-object (host stream :type t :identity t) (write (logical-host-name host) :stream stream))) (defstruct (logical-host (:include host (:parse #'parse-logical-namestring) (:unparse #'unparse-logical-namestring) (:unparse-host #'(lambda (x) (logical-host-name (%pathname-host x)))) (:unparse-directory #'unparse-logical-directory) (:unparse-file #'unparse-unix-file) (:unparse-enough #'unparse-enough-namestring) (:customary-case :upper)) (:print-function %print-logical-host) (:make-load-form-fun make-logical-host-load-form-fun)) (name "" :type simple-base-string) (translations nil :type list) (canon-transls nil :type list)) (defun make-logical-host-load-form-fun (logical-host) (values `(find-logical-host ',(logical-host-name logical-host)) nil)) ;;; The various magic tokens that are allowed to appear in pretty much all ;;; pathname components. ;;; (deftype component-tokens () '(member nil :unspecific :wild)) ;;;; Pathname structures (defstruct (pathname (:conc-name %pathname-) (:print-function %print-pathname) (:constructor %make-pathname (host device directory name type version)) (:predicate pathnamep) (:make-load-form-fun :just-dump-it-normally)) ;; Slot holds the host, at present either a UNIX or logical host. (host nil :type (or host null)) ;; Device is the name of a logical or physical device holding files. (device nil :type (or simple-string component-tokens)) ;; A list of strings that are the component subdirectory components. (directory nil :type list) ;; The filename. (name nil :type (or simple-string pattern component-tokens)) ;; The type extension of the file. (type nil :type (or simple-string pattern component-tokens)) ;; The version number of the file, a positive integer, but not supported ;; on standard UNIX filesystems. (version nil :type (or integer component-tokens (member :newest)))) ;;; %PRINT-PATHNAME -- Internal ;;; ;;; The printed representation of the pathname structure. ;;; (defun %print-pathname (pathname stream depth) (declare (ignore depth)) (let* ((host (%pathname-host pathname)) (namestring (if host (handler-case (namestring pathname) (error nil)) nil))) (cond (namestring (if (or *print-escape* *print-readably*) (format stream "#P~S" namestring) (format stream "~A" namestring))) (t (let ((device (%pathname-device pathname)) (directory (%pathname-directory pathname)) (name (%pathname-name pathname)) (type (%pathname-type pathname)) (version (%pathname-version pathname))) (cond ((every #'(lambda (d) (or (stringp d) (symbolp d))) (cdr directory)) ;; A CMUCL extension. If we have an unprintable ;; pathname, convert it to a form that would be ;; suitable as args to MAKE-PATHNAME to recreate ;; the pathname. ;; ;; We don't handle search-lists because we don't ;; currently have a readable syntax for ;; search-lists. (collect ((result)) (unless (eq host *unix-host*) (result :host) (result (if host (pathname-host pathname) nil))) (when device (result :device) (result device)) (when directory (result :directory) (result directory)) (when name (result :name) (result name)) (when type (result :type) (result type)) (when version (result :version) (result version)) (format stream "#P~S" (result)))) (*print-readably* (error 'print-not-readable :object pathname)) (t (funcall (formatter "#") stream (%pathname-host pathname) (%pathname-device pathname) (%pathname-directory pathname) (%pathname-name pathname) (%pathname-type pathname) (%pathname-version pathname))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Logical pathnames have the following format: ;;; ;;; logical-namestring ::= ;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] ;;; ;;; host ::= word ;;; directory ::= word | wildcard-word | ** ;;; name ::= word | wildcard-word ;;; type ::= word | wildcard-word ;;; version ::= pos-int | newest | NEWEST | * ;;; word ::= {uppercase-letter | digit | -}+ ;;; wildcard-word ::= [word] '* {word '*}* [word] ;;; pos-int ::= integer > 0 ;;; ;;; Physical pathnames include all these slots and a device slot. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Logical pathnames are a subclass of pathname, their class relations are ;; mimiced using structures for efficency. (defstruct (logical-pathname (:conc-name %logical-pathname-) (:print-function %print-logical-pathname) (:include pathname) (:constructor %make-logical-pathname (host device directory name type version)) (:make-load-form-fun :just-dump-it-normally))) (declaim (freeze-type logical-pathname logical-host)) ;;; %PRINT-LOGICAL-PATHNAME -- Internal ;;; ;;; The printed representation of the logical-pathname structure. ;;; The potential conflict with search-lists requires isolating the printed ;;; representation to use the i/o macro #.(logical-pathname ). ;;; ;;; Is there really a potential conflict? CMUCL does not allow ;;; search-list hosts and logical pathname hosts have the same name. ;;; Hence, if we use #P to print them out, we can always read them ;;; back without confusion. (rtoy) ;;; (defun %print-logical-pathname (pathname stream depth) (declare (ignore depth)) (let ((namestring (handler-case (namestring pathname) (error nil)))) (cond (namestring (if (or *print-escape* *print-readably*) (format stream "#P~S" namestring) (format stream "~A" namestring))) (*print-readably* (error 'print-not-readable :object pathname)) (t (funcall (formatter "#") stream (%pathname-host pathname) (%pathname-directory pathname) (%pathname-name pathname) (%pathname-type pathname) (%pathname-version pathname)))))) ;;; %MAKE-PATHNAME-OBJECT -- internal ;;; ;;; A pathname is logical if the host component is a logical-host. ;;; This constructor is used to make an instance of the correct type ;;; from parsed arguments. (defun %make-pathname-object (host device directory name type version) (if (typep host 'logical-host) (flet ((upcasify (thing) (typecase thing (list (mapcar #'(lambda (x) (if (stringp x) (string-upcase x) x)) thing)) (simple-base-string (string-upcase thing)) (t thing)))) (%make-logical-pathname host :unspecific (upcasify directory) (upcasify name) (upcasify type) (upcasify version))) (%make-pathname host device directory name type version))) ;;; *LOGICAL-HOSTS* --internal. ;;; ;;; Hash table searching maps a logical-pathname's host to their physical ;;; pathname translation. (defvar *logical-hosts* (make-hash-table :test #'equal)) ;;; PATH-DESIGNATOR -- internal type ;;; (deftype path-designator () "A path specification, either a string, file-stream or pathname." ;; This used to be stream, not file-stream, but ANSI CL says a ;; pathname designator is a string, a pathname or a stream ;; associated with a file. In the places we use path-designator, we ;; are really talking about ANSI pathname designators. '(or string file-stream pathname)) ;;;; Patterns ;;; Patterns are a list of entries and wildcards used for pattern matches ;;; of translations. (defstruct (pattern (:print-function %print-pattern) (:make-load-form-fun :just-dump-it-normally) (:constructor make-pattern (pieces))) (pieces nil :type list)) ;;; %PRINT-PATTERN -- Internal ;;; (defun %print-pattern (pattern stream depth) (declare (ignore depth)) (print-unreadable-object (pattern stream :type t) (if *print-pretty* (let ((*print-escape* t)) (pprint-fill stream (pattern-pieces pattern) nil)) (prin1 (pattern-pieces pattern) stream)))) ;;; PATTERN= -- Internal ;;; (defun pattern= (pattern1 pattern2) (declare (type pattern pattern1 pattern2)) (let ((pieces1 (pattern-pieces pattern1)) (pieces2 (pattern-pieces pattern2))) (and (= (length pieces1) (length pieces2)) (every #'(lambda (piece1 piece2) (typecase piece1 (simple-string (and (simple-string-p piece2) (string= piece1 piece2))) (cons (and (consp piece2) (eq (car piece1) (car piece2)) (string= (cdr piece1) (cdr piece2)))) (t (eq piece1 piece2)))) pieces1 pieces2)))) ;;; PATTERN-MATCHES -- Internal ;;; ;;; If the string matches the pattern returns the multiple values T and a ;;; list of the matched strings. ;;; (defun pattern-matches (pattern string) (declare (type pattern pattern) (type simple-string string)) (let ((len (length string))) (labels ((maybe-prepend (subs cur-sub chars) (if cur-sub (let* ((len (length chars)) (new (make-string len)) (index len)) (dolist (char chars) (setf (schar new (decf index)) char)) (cons new subs)) subs)) (matches (pieces start subs cur-sub chars) (if (null pieces) (if (= start len) (values t (maybe-prepend subs cur-sub chars)) (values nil nil)) (let ((piece (car pieces))) (etypecase piece (simple-string (let ((end (+ start (length piece)))) (and (<= end len) (string= piece string :start2 start :end2 end) (matches (cdr pieces) end (maybe-prepend subs cur-sub chars) nil nil)))) (list (ecase (car piece) (:character-set (and (< start len) (let ((char (schar string start))) (if (find char (second piece) :test #'char=) (matches (cdr pieces) (1+ start) subs t (cons char chars)))))))) ((member :single-char-wild) (and (< start len) (matches (cdr pieces) (1+ start) subs t (cons (schar string start) chars)))) ((member :multi-char-wild) (multiple-value-bind (won new-subs) (matches (cdr pieces) start subs t chars) (if won (values t new-subs) (and (< start len) (matches pieces (1+ start) subs t (cons (schar string start) chars))))))))))) (multiple-value-bind (won subs) (matches (pattern-pieces pattern) 0 nil nil nil) (values won (reverse subs)))))) ;;; DIRECTORY-COMPONENTS-MATCH -- Internal ;;; ;;; Pathname-match-p for directory components. If thing is empty ;;; then it matches :wild, (:absolute :wild-inferiors), or (:relative ;;; :wild-inferiors). ;;; (defun directory-components-match (thing wild) (or (eq thing wild) (eq wild :wild) (and (consp wild) (let ((wild1 (first wild))) (cond ((and (null thing) (member wild1 '(:absolute :relative))) (equal (rest wild) '(:wild-inferiors))) ((eq wild1 :wild-inferiors) (let ((wild-subdirs (rest wild))) (or (null wild-subdirs) (loop (when (directory-components-match thing wild-subdirs) (return t)) (pop thing) (unless thing (return nil)))))) ((consp thing) (and (components-match (first thing) wild1) (directory-components-match (rest thing) (rest wild))))))))) ;;; COMPONENTS-MATCH -- Internal ;;; ;;; Return true if pathname component Thing is matched by Wild. Not ;;; commutative. ;;; (defun components-match (thing wild) (declare (type (or pattern symbol simple-string integer) thing wild)) (or (eq thing wild) (eq wild :wild) (typecase thing (simple-base-string ;; String is matched by itself, a matching pattern or :WILD. (typecase wild (pattern (values (pattern-matches wild thing))) (simple-base-string (string= thing wild)))) (pattern ;; A pattern is only matched by an identical pattern. (and (pattern-p wild) (pattern= thing wild))) (integer ;; an integer (version number) is matched by :WILD or the same ;; integer. This branch will actually always be NIL as long is the ;; version is a fixnum. (eql thing wild))))) ;;; COMPARE-COMPONENT -- Internal ;;; ;;; A predicate for comparing two pathname slot component sub-entries. ;;; (defun compare-component (this that) (or (eql this that) (typecase this (simple-string (and (simple-string-p that) (string= this that))) (pattern (and (pattern-p that) (pattern= this that))) (cons (and (consp that) (compare-component (car this) (car that)) (compare-component (cdr this) (cdr that))))))) ;; Compare the version component. We treat NIL to be EQUAL to ;; :NEWEST. (defun compare-version-component (this that) (or (eql this that) (and (null this) (eq that :newest)) (and (null that) (eq this :newest)))) ;;;; Pathname functions. ;;; Implementation determined defaults to pathname slots. (defvar *default-pathname-defaults*) ;;; PATHNAME= -- Internal ;;; (defun pathname= (pathname1 pathname2) (declare (type pathname pathname1) (type pathname pathname2)) (and (eq (%pathname-host pathname1) (%pathname-host pathname2)) (compare-component (%pathname-device pathname1) (%pathname-device pathname2)) (compare-component (%pathname-directory pathname1) (%pathname-directory pathname2)) (compare-component (%pathname-name pathname1) (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) (%pathname-type pathname2)) (compare-version-component (%pathname-version pathname1) (%pathname-version pathname2)))) ;;; WITH-PATHNAME -- Internal ;;; Converts the expr, a pathname designator (a pathname, or string, or ;;; stream), into a pathname. ;;; (defmacro with-pathname ((var expr) &body body) `(let ((,var (let ((,var ,expr)) (etypecase ,var (pathname ,var) (string (parse-namestring ,var)) (file-stream (file-name ,var)) (stream:file-simple-stream (file-name ,var)))))) ,@body)) ;;; WITH-HOST -- Internal ;;; ;;; Converts the var, a host or string name for a host, into a logical-host ;;; structure or nil if not defined. ;;; ;;; pw notes 1/12/97 this potentially useful macro is not used anywhere ;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed. ;;; (defmacro with-host ((var expr) &body body) `(let ((,var (let ((,var ,expr)) (typecase ,var (logical-host ,var) (string (find-logical-host ,var nil)) (t nil))))) ,@body)) ;;; PATHNAME -- Interface ;;; (defun pathname (thing) "Convert thing (a pathname, string or stream) into a pathname." (declare (type path-designator thing)) (with-pathname (pathname thing) pathname)) ;;; MAYBE-DIDDLE-CASE -- Internal ;;; ;;; Change the case of thing if diddle-p T. ;;; (defun maybe-diddle-case (thing diddle-p) (if (and diddle-p (not (or (symbolp thing) (integerp thing)))) (labels ((check-for (pred in) (typecase in (pattern (dolist (piece (pattern-pieces in)) (when (typecase piece (simple-string (check-for pred piece)) (cons (case (car in) (:character-set (check-for pred (cdr in)))))) (return t)))) (list (dolist (x in) (when (check-for pred x) (return t)))) (simple-base-string (dotimes (i (length in)) (when (funcall pred (schar in i)) (return t)))) (t nil))) (diddle-with (fun thing) (typecase thing (pattern (make-pattern (mapcar #'(lambda (piece) (typecase piece (simple-base-string (funcall fun piece)) (cons (case (car piece) (:character-set (cons :character-set (funcall fun (cdr piece)))) (t piece))) (t piece))) (pattern-pieces thing)))) (list (mapcar fun thing)) (simple-base-string (funcall fun thing)) (t thing)))) (let ((any-uppers (check-for #'upper-case-p thing)) (any-lowers (check-for #'lower-case-p thing))) (cond ((and any-uppers any-lowers) ;; Mixed case, stays the same. thing) (any-uppers ;; All uppercase, becomes all lower case. (diddle-with #'(lambda (x) (if (stringp x) (string-downcase x) x)) thing)) (any-lowers ;; All lowercase, becomes all upper case. (diddle-with #'(lambda (x) (if (stringp x) (string-upcase x) x)) thing)) (t ;; No letters? I guess just leave it. thing)))) thing)) ;;; MERGE-DIRECTORIES -- Internal ;;; (defun merge-directories (dir1 dir2 diddle-case) (if (or (eq (car dir1) :absolute) (null dir2)) dir1 (let ((results nil)) (flet ((add (dir) (if (and (eq dir :back) (cdr results) (not (eq (car results) :back))) (pop results) (push dir results)))) (dolist (dir (maybe-diddle-case dir2 diddle-case)) (add dir)) (dolist (dir (cdr dir1)) (add dir))) (reverse results)))) ;;; MERGE-PATHNAMES -- Interface ;;; (defun merge-pathnames (pathname &optional (defaults *default-pathname-defaults*) (default-version :newest)) "Construct a filled in pathname by completing the unspecified components from the defaults." (declare (type path-designator pathname) (type path-designator defaults) (values pathname)) (with-pathname (defaults defaults) (let ((pathname (let ((*default-pathname-defaults* defaults)) (pathname pathname)))) (let* ((default-host (%pathname-host defaults)) (pathname-host (%pathname-host pathname)) (diddle-case (and default-host pathname-host (not (eq (host-customary-case default-host) (host-customary-case pathname-host)))))) (make-pathname :host (or pathname-host default-host) :device (or (%pathname-device pathname) (maybe-diddle-case (%pathname-device defaults) diddle-case)) :directory (merge-directories (%pathname-directory pathname) (%pathname-directory defaults) diddle-case) :name (or (%pathname-name pathname) (maybe-diddle-case (%pathname-name defaults) diddle-case)) :type (or (%pathname-type pathname) (maybe-diddle-case (%pathname-type defaults) diddle-case)) :version (or (if (null (%pathname-name pathname)) (or (%pathname-version pathname) (%pathname-version defaults)) (%pathname-version pathname)) default-version)))))) ;;; IMPORT-DIRECTORY -- Internal ;;; (defun import-directory (directory diddle-case) (etypecase directory (null nil) ((member :wild) '(:absolute :wild-inferiors)) ((member :unspecific) '(:relative)) (list (collect ((results)) (ecase (pop directory) (:absolute (results :absolute) (when (search-list-p (car directory)) (results (pop directory)))) (:relative (results :relative))) (dolist (piece directory) (cond ((member piece '(:wild :wild-inferiors :up :back)) (results piece)) ((or (simple-string-p piece) (pattern-p piece)) (results (maybe-diddle-case piece diddle-case))) ((stringp piece) (results (maybe-diddle-case (coerce piece 'simple-string) diddle-case))) (t (error (intl:gettext "~S is not allowed as a directory component.") piece)))) (results))) (simple-string `(:absolute ,(maybe-diddle-case directory diddle-case))) (string `(:absolute ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case))))) ;;; MAKE-PATHNAME -- Interface ;;; (defun make-pathname (&key (host nil hostp) (device nil devp) (directory nil dirp) (name nil namep) (type nil typep) (version nil versionp) defaults (case :local)) "Makes a new pathname from the component arguments. Note that host is a host-structure or string." (declare (type (or null string host component-tokens) host) (type (or string component-tokens) device) (type (or list string pattern component-tokens) directory) (type (or string pattern component-tokens) name type) (type (or integer component-tokens (member :newest)) version) (type (or path-designator null) defaults) (type (member :common :local) case)) (let* ((defaults (when defaults (with-pathname (defaults defaults) defaults))) (default-host (if defaults (%pathname-host defaults) (%pathname-host *default-pathname-defaults*))) ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a ;; string (as a logical-host) for the host part. We map that ;; string into the corresponding logical host structure. ;; pw@snoopy.mv.com: ;; HyperSpec says for the arg to MAKE-PATHNAME; ;; "host---a valid physical pathname host. ..." ;; where it probably means -- a valid pathname host. ;; "valid pathname host n. a valid physical pathname host or ;; a valid logical pathname host." ;; and defines ;; "valid physical pathname host n. any of a string, ;; a list of strings, or the symbol :unspecific, ;; that is recognized by the implementation as the name of a host." ;; "valid logical pathname host n. a string that has been defined ;; as the name of a logical host. ..." ;; HS is silent on what happens if the :host arg is NOT one of these. ;; It seems an error message is appropriate. (host (typecase host (host host) ; A valid host, use it. ((string 0) default-host) ; "" cannot be a logical host (string (find-logical-host host t)) ; logical-host or lose. (t ;; If the user specifically set :host to be NIL, use ;; it. Otherwise, we use the default host. (if (and hostp (null host)) nil default-host)))) (diddle-args ;; What to do if no host is given? Can't figure out the ;; customary case, so I (rtoy) am going to assume we don't ;; need to diddle args. (and host (eq (host-customary-case host) :lower) (eq case :common))) (diddle-defaults ;; Same for diddle-defaults. Do nothing if no host was given. (and host (not (eq (host-customary-case host) (host-customary-case default-host))))) (dev (if devp device (if defaults (%pathname-device defaults)))) (dir (import-directory directory diddle-args)) ;; CLHS MERGE-PATHNAMES (via MAKE-PATHNAME) says ;; ;; If pathname does not specify a name, then the version, if ;; not provided, will come from default-pathname, just like ;; the other components. If pathname does specify a name, ;; then the version is not affected by default-pathname. If ;; this process leaves the version missing, the ;; default-version is used. (ver (cond (versionp version) (namep version) (defaults (%pathname-version defaults)) (t nil)))) (when (and defaults (not dirp)) (setf dir (merge-directories dir (%pathname-directory defaults) diddle-defaults))) ;; A bit of sanity checking on user arguments. (flet ((check-component-validity (name name-or-type) (when (stringp name) (let ((unix-directory-separator #\/)) (when (eq host (%pathname-host *default-pathname-defaults*)) (when (find unix-directory-separator name) (warn (intl:gettext "Silly argument for a unix ~A: ~S") name-or-type name))))))) (check-component-validity name :pathname-name) (check-component-validity type :pathname-type) (mapc #'(lambda (d) (check-component-validity d :directory)) (cdr dir)) (when (and (stringp name) (or (and (string= name "..") (not type)) (and (string= name ".") (not type)))) ;; (warn (intl:gettext "Silly argument for a unix PATHNAME-NAME: ~S") name))) ;; More sanity checking (when dir ;; Try to canonicalize the directory component. :absolute ;; followed by a bunch of "/" deletes the leading "/"'s. ;; :relative followed by "." anywhere gets them all deleted. (ecase (first dir) (:absolute (do ((p (cdr dir) (cdr p))) ((or (null p) (not (equal "/" (car p)))) (setf (cdr dir) p)))) (:relative (setf (cdr dir) (delete "." (cdr dir) :test #'equal))))) ;; CLHS 19.2.2.4.3 says :absolute or :wild-inferiors immediately ;; followed by :up or :back signals a file-error. (let ((d (or (member :wild-inferiors dir) (member :absolute dir)))) (when (and d (rest d) (member (second d) '(:up :back))) ;; What should we put in the for pathname part of file-error? ;; I'm just going to use the directory but removing the ;; offending :up or :back. Or would just (make-pathname) be ;; enough? ;; ;; Or instead of checking here, we could check whenever we ;; "use" the file system (CLHS 19.2.2.4.3). But that's a lot ;; harder to do. (error 'simple-file-error :pathname (make-pathname :directory (remove-if #'(lambda (x) (member x '(:up :back))) dir)) :format-control (intl:gettext "Illegal pathname: ~ Directory with ~S immediately followed by ~S") :format-arguments (list (first d) (second d))))) (macrolet ((pick (var varp field) `(cond ((or (simple-string-p ,var) (pattern-p ,var)) (maybe-diddle-case ,var diddle-args)) ((stringp ,var) (maybe-diddle-case (coerce ,var 'simple-string) diddle-args)) (,varp (maybe-diddle-case ,var diddle-args)) (defaults (maybe-diddle-case (,field defaults) diddle-defaults)) (t nil)))) (%make-pathname-object host dev ; forced to :unspecific when logical-host dir (pick name namep %pathname-name) (pick type typep %pathname-type) ver)))) ;;; PATHNAME-HOST -- Interface ;;; (defun pathname-host (pathname &key (case :local)) "Accessor for the pathname's host." (declare (type path-designator pathname) (type (member :local :common) case) (values (or string null)) (ignore case)) (host-namestring pathname)) ;;; PATHNAME-DEVICE -- Interface ;;; (defun pathname-device (pathname &key (case :local)) "Accessor for pathname's device." (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-device pathname) (and (eq case :common) (eq (host-customary-case (%pathname-host pathname)) :lower))))) ;;; PATHNAME-DIRECTORY -- Interface ;;; (defun pathname-directory (pathname &key (case :local)) "Accessor for the pathname's directory list." (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) ;; CLHS 19.2.2.1.2.2 says: "should receive and yield strings in ;; component values" ;; ;; We take this to mean it applies to each component of the ;; directory individually. This also matches the example in the ;; entry for PATHNAME-HOST. (let ((diddle-p (and (eq case :common) (eq (host-customary-case (%pathname-host pathname)) :lower)))) (mapcar #'(lambda (piece) (maybe-diddle-case piece diddle-p)) (%pathname-directory pathname))))) ;;; PATHNAME-NAME -- Interface ;;; (defun pathname-name (pathname &key (case :local)) "Accessor for the pathname's name." (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-name pathname) (and (eq case :common) (eq (host-customary-case (%pathname-host pathname)) :lower))))) ;;; PATHNAME-TYPE ;;; (defun pathname-type (pathname &key (case :local)) "Accessor for the pathname's name." (declare (type path-designator pathname) (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-type pathname) (and (eq case :common) (eq (host-customary-case (%pathname-host pathname)) :lower))))) ;;; PATHNAME-VERSION ;;; (defun pathname-version (pathname) "Accessor for the pathname's version." (declare (type path-designator pathname)) (with-pathname (pathname pathname) (%pathname-version pathname))) ;;;; Namestrings ;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal ;;; (defun %print-namestring-parse-error (condition stream) (format stream (intl:gettext "Parse error in namestring: ~?~% ~A~% ~V@T^") (namestring-parse-error-complaint condition) (namestring-parse-error-arguments condition) (namestring-parse-error-namestring condition) (namestring-parse-error-offset condition))) (define-condition namestring-parse-error (parse-error type-error) ((complaint :reader namestring-parse-error-complaint :initarg :complaint) (arguments :reader namestring-parse-error-arguments :initarg :arguments :initform nil) (namestring :reader namestring-parse-error-namestring :initarg :namestring) (offset :reader namestring-parse-error-offset :initarg :offset)) (:report %print-namestring-parse-error)) ;;; %PARSE-NAMESTRING -- Internal ;;; ;;; Handle the case where parse-namestring is actually parsing a namestring. ;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing, ;;; call the parser, then check if the host matches. ;;; (defun %parse-namestring (namestr host defaults start end junk-allowed) (declare (type string namestr) (type (or host string null) host) (type pathname defaults) (type index start) (type (or index null) end)) (if junk-allowed (handler-case (%parse-namestring namestr host defaults start end nil) (namestring-parse-error (condition) (values nil (namestring-parse-error-offset condition)))) (let* ((end (or end (length namestr))) (host (if (and host (stringp host)) (find-logical-host host) host)) (default-host (%pathname-host defaults)) (parse-host (or host (extract-logical-host-prefix namestr start end) default-host))) (unless parse-host (error (intl:gettext "When Host arg is not supplied, Defaults arg must ~ have a non-null PATHNAME-HOST."))) (multiple-value-bind (new-host device directory file type version) (funcall (host-parse parse-host) namestr start end) (when (and host new-host (not (eq new-host host))) (error (intl:gettext "Host in namestring: ~S~@ does not match explicit host argument: ~S") namestr host)) (let ((pn-host (or new-host parse-host))) (values (%make-pathname-object pn-host device directory file type version) end)))))) ;;; EXTRACT-LOGICAL-HOST-PREFIX -- Internal ;;; ;;; If namestr begins with a colon-terminated, defined, logical host, then ;;; return that host, otherwise return NIL. ;;; (defun extract-logical-host-prefix (namestr start end) (declare (type simple-base-string namestr) (type index start end) (values (or logical-host null))) (let ((colon-pos (position #\: namestr :start start :end end))) (if colon-pos (find-logical-host (nstring-upcase (subseq namestr start colon-pos)) nil) nil))) ;;; PARSE-NAMESTRING -- Interface ;;; (defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) end junk-allowed) "Converts pathname, a pathname designator, into a pathname structure, for a physical pathname, returns the printed representation. Host may be a physical host structure or host namestring." (declare (type path-designator thing) (type (or list string host (member :unspecific)) host) (type path-designator defaults) (type index start) (type (or index null) end)) ;; Generally, redundant specification of information in software, ;; whether in code or in comments, is bad. However, the ANSI spec ;; for this is messy enough that it's hard to hold in short-term ;; memory, so I've recorded these redundant notes on the ;; implications of the ANSI spec. ;; ;; According to the ANSI spec, HOST can be a valid pathname host, or ;; a logical host, or NIL. ;; ;; A valid pathname host can be a valid physical pathname host or a ;; valid logical pathname host. ;; ;; A valid physical pathname host is "any of a string, a list of ;; strings, or the symbol :UNSPECIFIC, that is recognized by the ;; implementation as the name of a host". In SBCL as of 0.6.9.8, ;; that means :UNSPECIFIC: though someday we might want to ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like ;; '("RTFM" "MIT" "EDU"), that's not supported now. ;; ;; A valid logical pathname host is a string which has been defined as ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. ;; (let ((host (etypecase host ((string 0) ;; This is a special host. It's not valid as a ;; logical host, so it is a sensible thing to ;; designate the physical Unix host object. So ;; we do that. *unix-host*) (string ;; In general ANSI-compliant Common Lisps, a ;; string might also be a physical pathname host, ;; but ANSI leaves this up to the implementor, ;; and in CMUCL we don't do it, so it must be a ;; logical host. (find-logical-host host)) ((or null (member :unspecific)) ;; CLHS says that HOST=:UNSPECIFIC has ;; implementation-defined behavior. We ;; just turn it into NIL. nil) (list ;; ANSI also allows LISTs to designate hosts, ;; but leaves its interpretation ;; implementation-defined. Our interpretation ;; is that it's unsupported.:-| (error (intl:gettext "A LIST representing a pathname host is not ~ supported in this implementation:~% ~S") host)) (host host)))) (declare (type (or null host) host)) (with-pathname (defaults defaults) (etypecase thing (simple-string (%parse-namestring thing host defaults start end junk-allowed)) (string (%parse-namestring (coerce thing 'simple-string) host defaults start end junk-allowed)) (pathname (let ((host (if host host (%pathname-host defaults)))) (unless (eq host (%pathname-host thing)) (error (intl:gettext "Hosts do not match: ~S and ~S.") host (%pathname-host thing)))) (values thing start)) (stream (let ((name (file-name thing))) (unless name (error 'simple-type-error :datum thing :expected-type 'pathname :format-control (intl:gettext "Can't figure out the file associated with stream:~% ~S") :format-arguments (list thing))) (values name nil))))))) ;;; NAMESTRING -- Interface ;;; (defun namestring (pathname) "Construct the full (name)string form of the pathname." (declare (type path-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) (when pathname (let ((host (or (%pathname-host pathname) ;; Is this what we really want? Does a NIL host ;; really mean to get it from *d-p-d* and, if ;; that's NIL, use *unix-host*? (%pathname-host *default-pathname-defaults*) *unix-host*) )) (unless host (error (intl:gettext "Cannot determine the namestring for pathnames with no ~ host:~% ~S") pathname)) (funcall (host-unparse host) pathname))))) ;;; HOST-NAMESTRING -- Interface ;;; (defun host-namestring (pathname) "Returns a string representation of the name of the host in the pathname." (declare (type path-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host (funcall (host-unparse-host host) pathname) (error (intl:gettext "Cannot determine the namestring for pathnames with no host:~% ~S") pathname))))) ;;; DIRECTORY-NAMESTRING -- Interface ;;; (defun directory-namestring (pathname) "Returns a string representation of the directories used in the pathname." (declare (type path-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host (funcall (host-unparse-directory host) pathname) (error (intl:gettext "Cannot determine the namestring for pathnames with no host:~% ~S") pathname))))) ;;; FILE-NAMESTRING -- Interface ;;; (defun file-namestring (pathname) "Returns a string representation of the name used in the pathname." (declare (type path-designator pathname) (values (or null simple-base-string))) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host (funcall (host-unparse-file host) pathname) (error (intl:gettext "Cannot determine the namestring for pathnames with no host:~% ~S") pathname))))) ;;; ENOUGH-NAMESTRING -- Interface ;;; (defun enough-namestring (pathname &optional (defaults *default-pathname-defaults*)) "Returns an abbreviated pathname sufficent to identify the pathname relative to the defaults." (declare (type path-designator pathname defaults)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host (with-pathname (defaults defaults) ;; Give up if the hosts are different. I (rtoy) don't ;; think it makes sense to do anything if the hosts are ;; different. (if (equal host (%pathname-host defaults)) (funcall (host-unparse-enough host) pathname defaults) (namestring pathname))) (error (intl:gettext "Cannot determine the namestring for pathnames with no host:~% ~S") pathname))))) ;;;; Wild pathnames. ;;; WILD-PATHNAME-P -- Interface ;;; (defun wild-pathname-p (pathname &optional field-key) "Predicate for determining whether pathname contains any wildcards." (declare (type path-designator pathname) (type (member nil :host :device :directory :name :type :version) field-key)) (with-pathname (pathname pathname) (flet ((frob (x) (or (pattern-p x) (member x '(:wild :wild-inferiors))))) (ecase field-key ((nil) (or (wild-pathname-p pathname :host) (wild-pathname-p pathname :device) (wild-pathname-p pathname :directory) (wild-pathname-p pathname :name) (wild-pathname-p pathname :type) (wild-pathname-p pathname :version))) (:host (frob (%pathname-host pathname))) (:device (frob (%pathname-device pathname))) (:directory (some #'frob (%pathname-directory pathname))) (:name (frob (%pathname-name pathname))) (:type (frob (%pathname-type pathname))) (:version (frob (%pathname-version pathname))))))) ;;; PATHNAME-MATCH-P -- Interface ;;; (defun pathname-match-p (in-pathname in-wildname) "Pathname matches the wildname template?" (declare (type path-designator in-pathname) ;; Not path-designator because a file-stream can't have a ;; wild pathname. (type (or string pathname) in-wildname)) (with-pathname (pathname in-pathname) (with-pathname (wildname in-wildname) (macrolet ((frob (field &optional (op 'components-match )) `(or (null (,field wildname)) (,op (,field pathname) (,field wildname))))) (and (or (null (%pathname-host wildname)) (eq (%pathname-host wildname) (%pathname-host pathname))) (frob %pathname-device) (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) (frob %pathname-version)))))) ;;; SUBSTITUTE-INTO -- Internal ;;; ;;; Place the substitutions into the pattern and return the string or pattern ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well, ;;; in case we are translating between hosts with difference conventional case. ;;; The second value is the tail of subs with all of the values that we used up ;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards ;;; as a single string, so we ignore subsequent contiguous wildcards. ;;; (defun substitute-into (pattern subs diddle-case) (declare (type pattern pattern) (type list subs) (values (or simple-base-string pattern) list)) (let ((in-wildcard nil) (pieces nil) (strings nil)) (dolist (piece (pattern-pieces pattern)) (cond ((simple-string-p piece) (push piece strings) (setf in-wildcard nil)) (in-wildcard) (t (setf in-wildcard t) (unless subs (error (intl:gettext "Not enough wildcards in FROM pattern to match ~ TO pattern:~% ~S") pattern)) (let ((sub (pop subs))) (typecase sub (pattern (when strings (push (apply #'concatenate 'simple-string (nreverse strings)) pieces)) (dolist (piece (pattern-pieces sub)) (push piece pieces))) (simple-string (push sub strings)) (t (error (intl:gettext "Can't substitute this into the middle of a word:~ ~% ~S") sub))))))) (when strings (push (apply #'concatenate 'simple-string (nreverse strings)) pieces)) (values (maybe-diddle-case (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces))) (car pieces) (make-pattern (nreverse pieces))) diddle-case) subs))) ;;; DIDNT-MATCH-ERROR -- Internal ;;; ;;; Called when we can't see how source and from matched. ;;; (defun didnt-match-error (source from) (error (intl:gettext "Pathname components from Source and From args to TRANSLATE-PATHNAME~@ did not match:~% ~S ~S") source from)) ;;; TRANSLATE-COMPONENT -- Internal ;;; ;;; Do TRANSLATE-COMPONENT for all components except host and directory. ;;; (defun translate-component (source from to diddle-case) (typecase to (pattern (typecase from (pattern (typecase source (pattern (if (pattern= from source) source (didnt-match-error source from))) (simple-string (multiple-value-bind (won subs) (pattern-matches from source) (if won (values (substitute-into to subs diddle-case)) (didnt-match-error source from)))) (t (maybe-diddle-case source diddle-case)))) ((member :wild) (values (substitute-into to (list source) diddle-case))) (t (if (components-match source from) (maybe-diddle-case source diddle-case) (didnt-match-error source from))))) ((member nil :wild) (maybe-diddle-case source diddle-case)) (t (if (components-match source from) to (didnt-match-error source from))))) ;;; COMPUTE-DIRECTORY-SUBSTITUTIONS -- Internal ;;; ;;; Return a list of all the things that we want to substitute into the TO ;;; pattern (the things matched by from on source.) When From contains ;;; :WILD-INFERIORS, the result contains a sublist of the matched source ;;; subdirectories. ;;; (defun compute-directory-substitutions (orig-source orig-from) (let ((source orig-source) (from orig-from)) (collect ((subs)) (loop (unless source (unless (every #'(lambda (x) (eq x :wild-inferiors)) from) (didnt-match-error orig-source orig-from)) (subs ()) (return)) (unless from (didnt-match-error orig-source orig-from)) (let ((from-part (pop from)) (source-part (pop source))) (typecase from-part (pattern (typecase source-part (pattern (if (pattern= from-part source-part) (subs source-part) (didnt-match-error orig-source orig-from))) (simple-string (multiple-value-bind (won new-subs) (pattern-matches from-part source-part) (if won (dolist (sub new-subs) (subs sub)) (didnt-match-error orig-source orig-from)))) (t (didnt-match-error orig-source orig-from)))) ((member :wild) (subs source-part)) ((member :wild-inferiors) (let ((remaining-source (cons source-part source))) (collect ((res)) (loop (when (directory-components-match remaining-source from) (return)) (unless remaining-source (didnt-match-error orig-source orig-from)) (res (pop remaining-source))) (subs (res)) (setq source remaining-source)))) (simple-string (unless (and (simple-string-p source-part) (string= from-part source-part)) (didnt-match-error orig-source orig-from))) (t (didnt-match-error orig-source orig-from))))) (subs)))) ;;; TRANSLATE-DIRECTORIES -- Internal ;;; ;;; Called by TRANSLATE-PATHNAME on the directory components of its argument ;;; pathanames to produce the result directory component. If any leaves the ;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE ;;; is taken from the TO directory. ;;; (defun translate-directories (source from to diddle-case) (if (not (and source to from)) (let ((source (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))) (if (null to) source (collect ((res)) (res (cond ((null source) (first to)) ((eq (first to) :absolute) :absolute) (t (first source)))) (let ((match (rest source))) (dolist (to-part (rest to)) (cond ((eq to-part :wild) (when match (res (first match)) (setf match nil))) ((eq to-part :wild-inferiors) (when match (dolist (src-part match) (res src-part)) (setf match nil))) (t (res to-part))))) (res)))) (collect ((res)) (res (first to)) (let ((subs-left (compute-directory-substitutions (rest source) (rest from)))) (dolist (to-part (rest to)) (typecase to-part ((member :wild) (assert subs-left) (let ((match (pop subs-left))) (when (listp match) (error (intl:gettext ":WILD-INFERIORS not paired in from and to ~ patterns:~% ~S ~S") from to)) (res (maybe-diddle-case match diddle-case)))) ((member :wild-inferiors) (assert subs-left) (let ((match (pop subs-left))) (unless (listp match) (error (intl:gettext ":WILD-INFERIORS not paired in from and to ~ patterns:~% ~S ~S") from to)) (dolist (x match) (res (maybe-diddle-case x diddle-case))))) (pattern (multiple-value-bind (new new-subs-left) (substitute-into to-part subs-left diddle-case) (setf subs-left new-subs-left) (res new))) (t (res to-part))))) (res)))) ;;; TRANSLATE-PATHNAME -- Interface ;;; (defun translate-pathname (source from-wildname to-wildname &key) "Use the source pathname to translate the from-wildname's wild and unspecified elements into a completed to-pathname based on the to-wildname." (declare (type path-designator source from-wildname to-wildname)) (with-pathname (source source) (with-pathname (from from-wildname) (with-pathname (to to-wildname) (unless (pathname-match-p source from) (didnt-match-error source from)) (let* ((source-host (%pathname-host source)) (to-host (%pathname-host to)) (diddle-case (and source-host to-host (not (eq (host-customary-case source-host) (host-customary-case to-host)))))) (macrolet ((frob (field &optional (op 'translate-component)) `(let ((result (,op (,field source) (,field from) (,field to) diddle-case))) (if (eq result :error) (error (intl:gettext "~S doesn't match ~S") source from) result)))) (%make-pathname-object (or to-host source-host) (frob %pathname-device) (frob %pathname-directory translate-directories) (frob %pathname-name) (frob %pathname-type) (frob %pathname-version)))))))) ;;;; Search lists. ;;; The SEARCH-LIST structure. ;;; (defstruct (search-list (:print-function %print-search-list) (:make-load-form-fun (lambda (search-list) (values `(intern-search-list ',(search-list-name search-list)) nil)))) ;; ;; The name of this search-list. Always stored in lowercase. (name (required-argument) :type simple-string) ;; ;; T if this search-list has been defined. Otherwise NIL. (defined nil :type (member t nil)) ;; ;; The list of expansions for this search-list. Each expansion is the list ;; of directory components to use in place of this search-list. (expansions nil :type list)) (defun %print-search-list (sl stream depth) (declare (ignore depth)) (print-unreadable-object (sl stream :type t) (write-string (search-list-name sl) stream))) ;;; *SEARCH-LISTS* -- internal. ;;; ;;; Hash table mapping search-list names to search-list structures. ;;; (defvar *search-lists* (make-hash-table :test #'equal)) ;;; FIND-SEARCH-LIST -- internal ;;; (defun find-search-list (name &optional (flame-not-found-p t)) (let ((search-list (gethash (string-downcase name) *search-lists*))) (if search-list search-list (when flame-not-found-p (error (intl:gettext "Search-list ~a not defined.") name))))) ;;; INTERN-SEARCH-LIST -- internal interface. ;;; ;;; When search-lists are encountered in namestrings, they are converted to ;;; search-list structures right then, instead of waiting until the search ;;; list used. This allows us to verify ahead of time that there are no ;;; circularities and makes expansion much quicker. ;;; (defun intern-search-list (name) (let ((name (string-downcase name))) (or (gethash name *search-lists*) (let ((new (make-search-list :name name))) (setf (gethash name *search-lists*) new) new)))) ;;; CLEAR-SEARCH-LIST -- public. ;;; ;;; Clear the definition. Note: we can't remove it from the hash-table ;;; because there may be pathnames still refering to it. So we just clear ;;; out the expansions and set defined to NIL. ;;; (defun clear-search-list (name) "Clear the current definition for the search-list NAME. Returns T if such a definition existed, and NIL if not." (let* ((name (string-downcase name)) (search-list (gethash name *search-lists*))) (when (and search-list (search-list-defined search-list)) (setf (search-list-defined search-list) nil) (setf (search-list-expansions search-list) nil) t))) ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public. ;;; ;;; Again, we can't actually remove the entries from the hash-table, so we ;;; just mark them as being undefined. ;;; (defun clear-all-search-lists () "Clear the definition for all search-lists. Only use this if you know what you are doing." (maphash #'(lambda (name search-list) (declare (ignore name)) (setf (search-list-defined search-list) nil) (setf (search-list-expansions search-list) nil)) *search-lists*) nil) ;;; EXTRACT-SEARCH-LIST -- internal. ;;; ;;; Extract the search-list from PATHNAME and return it. If PATHNAME ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE ;;; is true) or return NIL (if FLAME-IF-NONE is false). ;;; (defun extract-search-list (pathname flame-if-none) (with-pathname (pathname pathname) (let* ((directory (%pathname-directory pathname)) (search-list (cadr directory))) (cond ((search-list-p search-list) search-list) (flame-if-none (error (intl:gettext "~S doesn't start with a search-list.") pathname)) (t nil))))) ;;; SEARCH-LIST -- public. ;;; ;;; We have to convert the internal form of the search-list back into a ;;; bunch of pathnames. ;;; (defun search-list (pathname) "Return the expansions for the search-list starting PATHNAME. If PATHNAME does not start with a search-list, then an error is signaled. If the search-list has not been defined yet, then an error is signaled. The expansion for a search-list can be set with SETF." (with-pathname (pathname pathname) (let ((search-list (extract-search-list pathname t)) (host (%pathname-host pathname))) (if (search-list-defined search-list) (mapcar #'(lambda (directory) (make-pathname :host host :directory (cons :absolute directory))) (search-list-expansions search-list)) (error (intl:gettext "Search list ~S has not been defined yet.") pathname))))) ;;; SEARCH-LIST-DEFINED-P -- public. ;;; (defun search-list-defined-p (pathname) "Returns T if the search-list starting PATHNAME is currently defined, and NIL otherwise. An error is signaled if PATHNAME does not start with a search-list." (with-pathname (pathname pathname) (search-list-defined (extract-search-list pathname t)))) ;;; %SET-SEARCH-LIST -- public setf method ;;; ;;; Set the expansion for the search-list in PATHNAME. If this would result ;;; in any circularities, we flame out. If anything goes wrong, we leave the ;;; old defintion intact. ;;; (defun %set-search-list (pathname values) (let ((search-list (extract-search-list pathname t))) (labels ((check (target-list path) (when (eq search-list target-list) (error (intl:gettext "That would result in a circularity:~% ~ ~A~{ -> ~A~} -> ~A") (search-list-name search-list) (reverse path) (search-list-name target-list))) (when (search-list-p target-list) (push (search-list-name target-list) path) (dolist (expansion (search-list-expansions target-list)) (check (car expansion) path)))) (convert (pathname) (with-pathname (pathname pathname) (when (or (pathname-name pathname) (pathname-type pathname) (pathname-version pathname)) (error (intl:gettext "Search-lists cannot expand into pathnames that have ~ a name, type, or ~%version specified:~% ~S") pathname)) (let ((directory (pathname-directory pathname))) (let ((expansion (if directory (ecase (car directory) (:absolute (cdr directory)) (:relative (cons (intern-search-list "default") (cdr directory)))) (list (intern-search-list "default"))))) (check (car expansion) nil) expansion))))) (setf (search-list-expansions search-list) (if (listp values) (mapcar #'convert values) (list (convert values))))) (setf (search-list-defined search-list) t)) values) ;;; ENUMERATE-SEARCH-LIST -- public. ;;; (defmacro enumerate-search-list ((var pathname &optional result) &body body) "Execute BODY with VAR bound to each successive possible expansion for PATHNAME and then return RESULT. Note: if PATHNAME does not contain a search-list, then BODY is executed exactly once. Everything is wrapped in a block named NIL, so RETURN can be used to terminate early. Note: VAR is *not* bound inside of RESULT." (let ((body-name (gensym))) `(block nil (flet ((,body-name (,var) ,@body)) (%enumerate-search-list ,pathname #',body-name) ,result)))) (defun %enumerate-search-list (pathname function) (let* ((pathname (if (logical-pathname-p pathname) (translate-logical-pathname pathname) pathname)) (search-list (extract-search-list pathname nil))) (cond ((not search-list) (funcall function pathname)) ((not (search-list-defined search-list)) (error (intl:gettext "Undefined search list: ~A") (search-list-name search-list))) (t (let ((tail (cddr (pathname-directory pathname)))) (dolist (expansion (search-list-expansions search-list)) (%enumerate-search-list (make-pathname :defaults pathname :directory (cons :absolute (append expansion tail))) function))))))) ;;;; Logical pathname support. ANSI 92-102 specification. ;;;; As logical-pathname translations are loaded they are canonicalized as ;;;; patterns to enable rapid efficent translation into physical pathnames. ;;;; Utilities: ;;; LOGICAL-WORD-OR-LOSE -- Internal ;;; ;;; Canonicalize a logical pathanme word by uppercasing it checking that it ;;; contains only legal characters. ;;; (defun logical-word-or-lose (word) (declare (string word)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)) (error 'namestring-parse-error :complaint (intl:gettext "Logical namestring character ~ is not alphanumeric or hyphen:~% ~S") :arguments (list ch) :namestring word :offset i)))) word)) ;;; FIND-LOGICAL-HOST -- Internal ;;; ;;; Given a logical host or string, return a logical host. If Error-p is ;;; NIL, then return NIL when no such host exists. ;;; (defun find-logical-host (thing &optional (errorp t)) (etypecase thing (string (let* ((valid-hostname (catch 'error-bailout (handler-bind ((namestring-parse-error (lambda(c)(declare (ignore c)) (unless errorp (throw 'error-bailout nil))))) (logical-word-or-lose thing)))) (found (and valid-hostname (or (gethash valid-hostname *logical-hosts*) (and *autoload-translations* (ignore-errors (load-logical-pathname-translations valid-hostname)) (gethash valid-hostname *logical-hosts*)))))) (if (or found (not errorp)) found (error 'simple-file-error :pathname thing :format-control (intl:gettext "Logical host not yet defined: ~S") :format-arguments (list thing))))) (logical-host thing))) ;;; INTERN-LOGICAL-HOST -- Internal ;;; ;;; Given a logical host name or host, return a logical host, creating a new ;;; one if necessary. ;;; (defun intern-logical-host (thing) (declare (values logical-host)) (or (find-logical-host thing nil) (let* ((name (logical-word-or-lose thing)) (new (make-logical-host :name name))) (setf (gethash name *logical-hosts*) new) new))) ;;;; Logical pathname parsing: ;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal ;;; ;;; Deal with multi-char wildcards in a logical pathname token. ;;; (defun maybe-make-logical-pattern (namestring chunks) (let ((chunk (caar chunks))) (collect ((pattern)) (let ((last-pos 0) (len (length chunk))) (declare (fixnum last-pos)) (loop (when (= last-pos len) (return)) (let ((pos (or (position #\* chunk :start last-pos) len))) (if (= pos last-pos) (when (pattern) (error 'namestring-parse-error :complaint (intl:gettext "Double asterisk inside of logical ~ word: ~S") :arguments (list chunk) :namestring namestring :offset (+ (cdar chunks) pos))) (pattern (subseq chunk last-pos pos))) (if (= pos len) (return) (pattern :multi-char-wild)) (setq last-pos (1+ pos))))) (assert (pattern)) (if (cdr (pattern)) (make-pattern (pattern)) (let ((x (car (pattern)))) (if (eq x :multi-char-wild) :wild x)))))) ;;; LOGICAL-CHUNKIFY -- Internal ;;; ;;; Return a list of conses where the cdr is the start position and the car ;;; is a string (token) or character (punctuation.) ;;; (defun logical-chunkify (namestr start end) (collect ((chunks)) (do ((i start (1+ i)) (prev start)) ((= i end) (when (> end prev) (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) (let ((ch (schar namestr i))) (unless (or (alpha-char-p ch) (digit-char-p ch) (member ch '(#\- #\*))) (when (> i prev) (chunks (cons (nstring-upcase (subseq namestr prev i)) prev))) (setq prev (1+ i)) (unless (member ch '(#\; #\: #\.)) (error 'namestring-parse-error :complaint (intl:gettext "Illegal character for logical pathname:~% ~S") :arguments (list ch) :namestring namestr :offset i)) (chunks (cons ch i))))) (chunks))) ;;; PARSE-LOGICAL-NAMESTRING -- Internal ;;; ;;; Break up a logical-namestring, always a string, into its constituent ;;; parts. ;;; (defun parse-logical-namestring (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (collect ((directory)) (let ((host nil) (name nil) (type nil) (version nil)) (labels ((expecting (what chunks) (unless (and chunks (simple-string-p (caar chunks))) (error 'namestring-parse-error :complaint (intl:gettext "Expecting ~A, got ~:[nothing~;~:*~S~].") :arguments (list (intl:gettext what) (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) (caar chunks)) (parse-host (chunks) (case (caadr chunks) (#\: (setq host (find-logical-host (expecting _N"a host name" chunks))) (parse-relative (cddr chunks))) (t (parse-relative chunks)))) (parse-relative (chunks) (case (caar chunks) (#\; (directory :relative) (parse-directory (cdr chunks))) (t (directory :absolute) ; Assumption! Maybe revoked later. (parse-directory chunks)))) (parse-directory (chunks) (case (caadr chunks) (#\; (directory (let ((res (expecting _N"a directory name" chunks))) (cond ((string= res "..") :up) ((string= res "**") :wild-inferiors) (t (maybe-make-logical-pattern namestr chunks))))) (parse-directory (cddr chunks))) (t (parse-name chunks)))) (parse-name (chunks) (when chunks (expecting _N"a file name" chunks) (setq name (maybe-make-logical-pattern namestr chunks)) (expecting-dot (cdr chunks)))) (expecting-dot (chunks) (when chunks (unless (eql (caar chunks) #\.) (error 'namestring-parse-error :complaint _N"Expecting a dot, got ~S." :arguments (list (caar chunks)) :namestring namestr :offset (cdar chunks))) (if type (parse-version (cdr chunks)) (parse-type (cdr chunks))))) (parse-type (chunks) (expecting _N"a file type" chunks) (setq type (maybe-make-logical-pattern namestr chunks)) (expecting-dot (cdr chunks))) (parse-version (chunks) (let ((str (expecting _N"a positive integer, * or NEWEST" chunks))) (cond ((string= str "*") (setq version :wild)) ((string= str "NEWEST") (setq version :newest)) (t (multiple-value-bind (res pos) (parse-integer str :junk-allowed t) (unless (and res (plusp res)) (error 'namestring-parse-error :complaint (intl:gettext "Expected a positive integer, ~ got ~S") :arguments (list str) :namestring namestr :offset (+ pos (cdar chunks)))) (setq version res))))) (when (cdr chunks) (error 'namestring-parse-error :complaint (intl:gettext "Extra stuff after end of file name.") :namestring namestr :offset (cdadr chunks))))) (parse-host (logical-chunkify namestr start end))) (values host :unspecific (directory) name type version)))) ;;; Can't defvar here because not all host methods are loaded yet. (declaim (special *logical-pathname-defaults*)) (defun logical-pathname-namestring-p (pathspec) ;; Checks to see if pathspec is a logical pathname or not. (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*))) ;; Even though *logical-pathname-defaults* has a host with name ;; BOGUS, the user can still use BOGUS as a logical host because ;; we compare with EQ here, so the users BOGUS host is never our ;; BOGUS host. (values (not (eq (%pathname-host res) (%pathname-host *logical-pathname-defaults*))) res))) ;;; LOGICAL-PATHNAME -- Public ;;; (defun logical-pathname (pathspec) "Converts the pathspec argument to a logical-pathname and returns it." (declare (type (or logical-pathname string stream) pathspec) (values logical-pathname)) (if (typep pathspec 'logical-pathname) pathspec (multiple-value-bind (logical-p res) (logical-pathname-namestring-p pathspec) (unless logical-p (error 'simple-type-error :format-control (intl:gettext "Logical namestring does not specify a host:~% ~S") :format-arguments (list pathspec) :datum pathspec :expected-type '(satisfies logical-pathname-namestring-p))) ;; Make sure the result is a logical pathname. This can ;; happen if the pathspec is stream, and the stream was opened ;; with a pathname instead of a logical-pathname. (check-type res logical-pathname) res))) ;;;; Logical pathname unparsing: ;;; UNPARSE-LOGICAL-DIRECTORY -- Internal ;;; (defun unparse-logical-directory (pathname) (declare (type pathname pathname)) (collect ((pieces)) (let ((directory (%pathname-directory pathname))) (when directory (ecase (pop directory) (:absolute) ;; Nothing special. (:relative (pieces ";"))) (dolist (dir directory) (cond ((or (stringp dir) (pattern-p dir)) (pieces (unparse-logical-piece dir)) (pieces ";")) ((eq dir :wild) (pieces "*;")) ((eq dir :wild-inferiors) (pieces "**;")) (t (error (intl:gettext "Invalid directory component: ~S") dir)))))) (apply #'concatenate 'simple-string (pieces)))) ;;; UNPARSE-LOGICAL-PIECE -- Internal ;;; (defun unparse-logical-piece (thing) (etypecase thing (simple-string thing) (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) (etypecase piece (simple-string (strings piece)) (keyword (cond ((eq piece :wild-inferiors) (strings "**")) ((eq piece :multi-char-wild) (strings "*")) (t (error (intl:gettext "Invalid keyword: ~S") piece)))))) (apply #'concatenate 'simple-string (strings)))))) ;;; UNPARSE-ENOUGH-NAMESTRING -- Internal ;;; (defun unparse-enough-namestring (pathname defaults) (let* ((path-dir (pathname-directory pathname)) (def-dir (pathname-directory defaults)) (enough-dir ;; Go down the directory lists to see what matches. What's ;; left is what we want, more or less. But there has to be ;; something in common. (cond ((and (eq (first path-dir) (first def-dir)) (eq (first path-dir) :absolute) (second path-dir) (second def-dir) (equal (second path-dir) (second def-dir))) ;; Both paths are :absolute, so find where the common ;; parts end and return what's left (do* ((p (rest path-dir) (rest p)) (d (rest def-dir) (rest d))) ((or (endp p) (endp d) (not (equal (first p) (first d)))) `(:relative ,@p)))) (t ;; Both paths are absolute, but there's nothing in ;; common, so return the original. Or one path is ;; :relative, so just return the original path. If ;; the original path is :relative, then that's the ;; right one. If PATH-DIR is :absolute, we want to ;; return that except when DEF-DIR is :absolute, as ;; handled above. so return the original directory. path-dir)))) (namestring (make-pathname :host (%pathname-host pathname) :directory enough-dir :name (pathname-name pathname) :type (pathname-type pathname) :version (pathname-version pathname))))) ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal ;;; (defun unparse-logical-namestring (pathname) (declare (type logical-pathname pathname)) (concatenate 'simple-string (logical-host-name (%pathname-host pathname)) ":" (unparse-logical-directory pathname) (unparse-unix-file pathname))) ;;;; Logical pathname translations: ;;; CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS -- Internal ;;; ;;; Verify that the list of translations consists of lists and prepare ;;; canonical translations (parse pathnames and expand out wildcards into ;;; patterns). ;;; (defun canonicalize-logical-pathname-translations (transl-list host) (declare (type list transl-list) (type host host) (values list)) (collect ((res)) (dolist (tr transl-list) (unless (and (consp tr) (= (length tr) 2)) (error (intl:gettext "Logical pathname translation is not a two-list:~% ~S") tr)) (let ((from (first tr))) (res (list (if (typep from 'logical-pathname) from (parse-namestring from host)) (pathname (second tr)))))) (res))) ;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public ;;; (defun logical-pathname-translations (host) "Return the (logical) host object argument's list of translations." (declare (type (or string logical-host) host) (values list)) (logical-host-translations (find-logical-host host))) ;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public ;;; (defun (setf logical-pathname-translations) (translations host) "Set the translations list for the logical host argument. Return translations." (declare (type (or string logical-host) host) (type list translations) (values list)) (let ((maybe-search-list-host (concatenate 'string host ":"))) (when (and (not (logical-pathname-p (pathname maybe-search-list-host))) (search-list-defined-p maybe-search-list-host)) (cerror (intl:gettext "Clobber search-list host with logical pathname host") (intl:gettext "~S names a CMUCL search-list") host))) (let ((host (intern-logical-host host))) (setf (logical-host-canon-transls host) (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) ;;; The search mechanism for loading pathname translations uses the CMUCL ;;; extension of search-lists. The user can add to the library: search-list ;;; using setf. The file for translations should have the name defined by ;;; the hostname (a string) and with type component "translations". ;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public ;;; (defun load-logical-pathname-translations (host) "Search for a logical pathname named host, if not already defined. If already defined no attempt to find or load a definition is attempted and NIL is returned. If host is not already defined, but definition is found and loaded successfully, T is returned, else error." (declare (type string host) (values (member t nil))) (let ((*autoload-translations* nil)) (unless (or (string-equal host "library") (find-logical-host host nil)) (with-open-file (in-str (make-pathname :defaults "library:" :name (string-downcase host) :type "translations")) (if *load-verbose* (format *error-output* (intl:gettext ";; Loading pathname translations from ~A~%") (namestring (truename in-str)))) (setf (logical-pathname-translations host) (read in-str))) t))) ;;; TRANSLATE-LOGICAL-PATHNAME -- Public ;;; (defun translate-logical-pathname (pathname &key) "Translates pathname to a physical pathname, which is returned." (declare (type path-designator pathname) (values (or null pathname))) (typecase pathname (logical-pathname (dolist (x (logical-host-canon-transls (%pathname-host pathname)) (error 'simple-file-error :pathname pathname :format-control (intl:gettext "No translation for ~S") :format-arguments (list pathname))) (destructuring-bind (from to) x (when (pathname-match-p pathname from) (return (translate-logical-pathname (translate-pathname pathname from to))))))) (pathname pathname) (stream (translate-logical-pathname (pathname pathname))) (t (translate-logical-pathname (pathname pathname))))) (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific nil nil nil nil)) cmucl-21a/src/code/pmax-disassem.lisp000066400000000000000000000411541260377556400177330ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pmax-disassem.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; A simple dissambler for the MIPS R2000. ;;; ;;; Written by Christopher Hoover. ;;; (in-package "MIPS" :use '("LISP")) (intl:textdomain "cmucl") (export '(register-name disassemble-code-vector)) ;;;; Instruction Layout ;;; ;;; Each instrunction on the MIPS R2000 consists of a single word (32 ;;; bits) aligned on a single word boundaray. There are three ;;; instrunction formats: ;;; ;;; I-Type (Immediate) ;;; ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ;;; --------------------------------------------------------------- ;;; [ op ] [ rs ] [ rt ] [ immediate ] ;;; --------------------------------------------------------------- ;;; ;;; ;;; J-Type (Jump) ;;; ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ;;; --------------------------------------------------------------- ;;; [ op ] [ target ] ;;; --------------------------------------------------------------- ;;; ;;; ;;; R-Type (Register) ;;; ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ;;; --------------------------------------------------------------- ;;; [ op ] [ rs ] [ rt ] [ rd ] [ shmat ] [ funct ] ;;; --------------------------------------------------------------- ;;; ;;; These instructions fall into 5 categories: Load/Store, ;;; Computational, Jump/Branch, Coprocessor, and Special. ;;; ;;;; Register Names (defun register-name (register-number) (unless (<= 0 register-number 31) (error "Illegal register number!")) (svref *register-names* register-number)) ;;;; Instruction Type Definition ;;; ;;; These instruction types correspond to the various ways the decoded ;;; instructions are printed which in turn corresponds somewhat to the ;;; way the instructions are decoded. ;;; (defvar *mips-instruction-types* (make-hash-table :test #'eq)) (defmacro def-mips-instruction-type (types &body body) `(let ((closure #'(lambda (name word stream) ,@body))) (dolist (type ',types) (when (gethash type *mips-instruction-types*) (warn "Instruction type ~S being redefined" type)) (setf (gethash type *mips-instruction-types*) closure)))) (defun mips-instruction-type-p (type) (not (not (gethash type *mips-instruction-types*)))) ;;;; Instruction Types ;;; ;;; Used later for relative branches. (defvar *current-instruction-number* 0) (def-mips-instruction-type (:ls-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (immed (signed-ldb (byte 16 0) word))) (format stream "~16,8T~A~8,8T~A, #x~X(~A)~%" name (register-name rt) immed (register-name rs)))) (def-mips-instruction-type (:si-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (immed (signed-ldb (byte 16 0) word))) (cond ((and (zerop rs) (or (string= name "ADDI") (string= name "ADDIU"))) (format stream "~16,8TLOADI~8,8T~A, #x~X~%" (register-name rt) immed)) ((and (= rs null-offset) (string= name "ADDI")) ;; Major hack ... (format stream "~16,8T~A~8,8T~A, ~A, #x~X~48,8T; ~S~%" name (register-name rt) (register-name rs) immed (vm:offset-static-symbol immed))) (t (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" name (register-name rt) (register-name rs) immed))))) (def-mips-instruction-type (:ui-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (immed (ldb (byte 16 0) word))) (cond ((and (zerop rs) (or (string= name "ORI") (string= name "XORI"))) (format stream "~16,8TLOADI~8,8T~A, #x~X~%" (register-name rt) immed)) (t (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" name (register-name rt) (register-name rs) immed))))) (def-mips-instruction-type (:lui-type) (let ((rt (ldb (byte 5 16) word)) (immed (ldb (byte 16 0) word))) (format stream "~16,8T~A~8,8T~A, #x~X~%" name (register-name rt) immed))) (def-mips-instruction-type (:j-type) (let ((target (ldb (byte 26 0) word))) (format stream "~16,8T~A~8,8Ttarget = ~D~%" name target))) (def-mips-instruction-type (:jr-type) (let ((rs (ldb (byte 5 21) word))) (format stream "~16,8T~A~8,8T~A~%" name (register-name rs)))) (def-mips-instruction-type (:jalr-type) (let ((rs (ldb (byte 5 21) word)) (rd (ldb (byte 5 11) word))) (format stream "~16,8T~A~8,8T~A, ~A~%" name (register-name rd) (register-name rs)))) (defun branch-target (offset) (+ *current-instruction-number* offset 1)) (def-mips-instruction-type (:branch-type) (let ((rs (ldb (byte 5 21) word)) (offset (signed-ldb (byte 16 0) word))) (format stream "~16,8T~A~8,8T~A, ~D~%" name (register-name rs) (branch-target offset)))) (def-mips-instruction-type (:branch2-type) (let* ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (offset (signed-ldb (byte 16 0) word)) (target (branch-target offset))) (cond ((and (zerop rs) (zerop rt) (string= name "BEQ")) (format stream "~16,8TB~8,8T~D~%" target)) (t (format stream "~16,8T~A~8,8T~A, ~A, ~D~%" name (register-name rs) (register-name rt) target))))) (def-mips-instruction-type (:r3-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (rd (ldb (byte 5 11) word))) (cond ((zerop rd) ;; Hack for NOP (format stream "~16,8TNOP~%")) ((and (zerop rt) (or (string= name "OR") (string= name "ADDU"))) ;; Hack for MOVE (format stream "~16,8TMOVE~8,8T~A, ~A~%" (register-name rd) (register-name rs))) (t (format stream "~16,8T~A~8,8T~A, ~A, ~A~%" name (register-name rd) (register-name rs) (register-name rt)))))) (def-mips-instruction-type (:mf-type) (let ((rd (ldb (byte 5 11) word))) (format stream "~16,8T~A~8,8T~A~%" name (register-name rd)))) (def-mips-instruction-type (:mt-type) (let ((rs (ldb (byte 5 21) word))) (format stream "~16,8T~A~8,8T~A~%" name (register-name rs)))) (def-mips-instruction-type (:mult-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word))) (format stream "~16,8T~A~8,8T~A, ~A~%" name (register-name rs) (register-name rt)))) (def-mips-instruction-type (:shift-type) (let ((rt (ldb (byte 5 16) word)) (rd (ldb (byte 5 11) word)) (shamt (ldb (byte 5 6) word))) ;; Hack for NOP (cond ((= word 0) (format stream "~16,8TNOP~%")) (t (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%" name (register-name rd) (register-name rt) shamt))))) (def-mips-instruction-type (:shiftv-type) (let ((rs (ldb (byte 5 21) word)) (rt (ldb (byte 5 16) word)) (rd (ldb (byte 5 11) word))) (format stream "~16,8T~A~8,8T~A, ~A, ~A~%" name (register-name rd) (register-name rt) (register-name rs)))) (def-mips-instruction-type (:break-type) (let ((code (ldb (byte 10 16) word))) ; The entire field is (byte 20 6) (format stream "~16,8T~A~8,8T#x~X~%" name code))) (def-mips-instruction-type (:syscall-type) (declare (ignore word)) (format stream "~16,8T~A~%" name)) (def-mips-instruction-type (:cop0-type :cop1-type :cop2-type :cop3-type) (format stream "~16,8T~A~8,8T(#x~X)~%" name word)) ;;;; Instruction Definition (defstruct (mips-instruction (:constructor make-mips-instruction (name type)) (:print-function %print-mips-instruction)) (name "" :type simple-string) type) (defun %print-mips-instruction (instr stream depth) (declare (ignore depth)) (format stream "#" (mips-instruction-name instr))) (defconstant mips-instruction-bits 6) (defvar *mips-instructions* (make-array (ash 1 mips-instruction-bits) :initial-element nil)) (declaim (type simple-vector *mips-instructions*)) (defmacro def-mips-instr (name op-code type) `(let ((name ,name) (type ,type)) (unless (mips-instruction-type-p type) (warn "~S is an unknown instruction type" type)) (setf (svref *mips-instructions* ,op-code) (make-mips-instruction name ,type)) name)) (defconstant mips-special-instruction-bits 6) (defvar *mips-special-instructions* (make-array (ash 1 mips-special-instruction-bits) :initial-element nil)) (declaim (type simple-vector *mips-special-instructions*)) (defmacro def-mips-special-instr (name op-code type) `(let ((name ,name) (type ,type)) (unless (mips-instruction-type-p type) (warn "~S is an unknown instruction type" type)) (setf (svref *mips-special-instructions* ,op-code) (make-mips-instruction name ,type)) name)) (defconstant mips-bcond-instruction-bits 6) (defvar *mips-bcond-instructions* (make-array (ash 1 mips-bcond-instruction-bits) :initial-element nil)) (declaim (type simple-vector *mips-bcond-instructions*)) (defmacro def-mips-bcond-instr (name op-code type) `(let ((name ,name) (type ,type)) (unless (mips-instruction-type-p type) (warn "~S is an unknown instruction type" type)) (setf (svref *mips-bcond-instructions* ,op-code) (make-mips-instruction name ,type)) name)) ;;;; Normal Opcodes (def-mips-instr "J" #b000010 :j-type) (def-mips-instr "JAL" #b000011 :j-type) (def-mips-instr "BEQ" #b000100 :branch2-type) (def-mips-instr "BNE" #b000101 :branch2-type) (def-mips-instr "BLEZ" #b000110 :branch-type) (def-mips-instr "BGTZ" #b000111 :branch-type) (def-mips-instr "ADDI" #b001000 :si-type) (def-mips-instr "ADDIU" #b001001 :si-type) (def-mips-instr "SLTI" #b001010 :si-type) (def-mips-instr "SLTIU" #b001011 :si-type) (def-mips-instr "ANDI" #b001100 :ui-type) (def-mips-instr "ORI" #b001101 :ui-type) (def-mips-instr "XORI" #b001110 :ui-type) (def-mips-instr "LUI" #b001111 :lui-type) (def-mips-instr "COP0" #b010000 :cop0-type) (def-mips-instr "COP1" #b010001 :cop1-type) (def-mips-instr "COP2" #b010010 :cop2-type) (def-mips-instr "COP3" #b010011 :cop3-type) (def-mips-instr "LB" #b100000 :ls-type) (def-mips-instr "LH" #b100001 :ls-type) (def-mips-instr "LWL" #b100010 :ls-type) (def-mips-instr "LW" #b100011 :ls-type) (def-mips-instr "LBU" #b100100 :ls-type) (def-mips-instr "LHU" #b100101 :ls-type) (def-mips-instr "LWR" #b100110 :ls-type) (def-mips-instr "SB" #b101000 :ls-type) (def-mips-instr "SH" #b101001 :ls-type) (def-mips-instr "SWL" #b101010 :ls-type) (def-mips-instr "SW" #b101011 :ls-type) (def-mips-instr "SWR" #b101110 :ls-type) (def-mips-instr "LWC0" #b110000 :cop0-type) (def-mips-instr "LWC1" #b110001 :cop1-type) (def-mips-instr "LWC2" #b110010 :cop2-type) (def-mips-instr "LWC3" #b110011 :cop3-type) (def-mips-instr "SWC0" #b111000 :cop0-type) (def-mips-instr "SWC1" #b111001 :cop1-type) (def-mips-instr "SWC2" #b111010 :cop2-type) (def-mips-instr "SWC3" #b111011 :cop3-type) ;;;; SPECIAL Opcodes (defconstant special-op #b000000) (def-mips-special-instr "SLL" #b000000 :shift-type) (def-mips-special-instr "SRL" #b000010 :shift-type) (def-mips-special-instr "SRA" #b000011 :shift-type) (def-mips-special-instr "SLLV" #b000100 :shiftv-type) (def-mips-special-instr "SRLV" #b000110 :shiftv-type) (def-mips-special-instr "SRAV" #b000111 :shiftv-type) (def-mips-special-instr "JR" #b001000 :jr-type) (def-mips-special-instr "JALR" #b001001 :jalr-type) (def-mips-special-instr "SYSCALL" #b001100 :syscall-type) (def-mips-special-instr "BREAK" #b001101 :break-type) (def-mips-special-instr "MFHI" #b010000 :mf-type) (def-mips-special-instr "MTHI" #b010001 :mt-type) (def-mips-special-instr "MFLO" #b010010 :mf-type) (def-mips-special-instr "MTLO" #b010011 :mt-type) (def-mips-special-instr "MULT" #b011000 :mult-type) (def-mips-special-instr "MULTU" #b011001 :mult-type) (def-mips-special-instr "DIV" #b011010 :mult-type) (def-mips-special-instr "DIVU" #b011011 :mult-type) (def-mips-special-instr "ADD" #b100000 :r3-type) (def-mips-special-instr "ADDU" #b100001 :r3-type) (def-mips-special-instr "SUB" #b100010 :r3-type) (def-mips-special-instr "SUBU" #b100011 :r3-type) (def-mips-special-instr "AND" #b100100 :r3-type) (def-mips-special-instr "OR" #b100101 :r3-type) (def-mips-special-instr "XOR" #b100110 :r3-type) (def-mips-special-instr "NOR" #b100111 :r3-type) (def-mips-special-instr "SLT" #b101010 :r3-type) (def-mips-special-instr "SLTU" #b101011 :r3-type) ;;;; BCOND Opcodes (defconstant bcond-op #b000001) (def-mips-bcond-instr "BLTZ" #b00000 :branch-type) (def-mips-bcond-instr "BLTZAL" #b00001 :branch-type) (def-mips-bcond-instr "BLTZAL" #b10000 :branch-type) (def-mips-bcond-instr "BGEZAL" #b10001 :branch-type) ;;;; Signed-Ldb (defun signed-ldb (byte-spec integer) (let ((unsigned (ldb byte-spec integer)) (length (byte-size byte-spec))) (if (logbitp (1- length) unsigned) (- unsigned (ash 1 length)) unsigned))) ;;;; Instruction Decoding (defun mips-instruction (word) (let* ((opcode (ldb (byte 6 26) word))) (cond ((= opcode special-op) (let ((function (ldb (byte 6 0) word))) (svref *mips-special-instructions* function))) ((= opcode bcond-op) (let ((cond (ldb (byte 5 16) word))) (svref *mips-bcond-instructions* cond))) (t (svref *mips-instructions* opcode))))) ;;;; Disassemble-Instruction (defun disassemble-instruction (word &optional (stream t)) (let* ((instr (mips-instruction word))) (cond (instr (let* ((instr-name (mips-instruction-name instr)) (instr-type (mips-instruction-type instr)) (closure (gethash instr-type *mips-instruction-types*))) (cond (closure (funcall closure instr-name word stream)) (t (format stream "UNKNOWN TYPE (~A/~S/#x~X)~%" instr-name instr-type word))) (values instr-name instr-type))) (t (format stream "~16,8TDATA~8,8T#x~X~%" word) (return-from disassemble-instruction (values nil nil)))))) ;;; Dissassemble-Code-Vector (defconstant delay-slot-instruction-types '(:j-type :jr-type :jalr-type :branch-type :branch2-type)) (defun disassemble-code-vector (code-vector length &optional (stream t)) (do ((i 0 (+ i 4)) (*current-instruction-number* 0 (1+ *current-instruction-number*)) (instruction-in-delay-slot-p nil)) ((>= i length)) (unless instruction-in-delay-slot-p (format stream "~6D:" *current-instruction-number*)) (multiple-value-bind (name type) (disassemble-instruction (logior (aref code-vector i) (ash (aref code-vector (+ i 1)) 8) (ash (aref code-vector (+ i 2)) 16) (ash (aref code-vector (+ i 3)) 24)) stream) (declare (ignore name)) (cond ((member type delay-slot-instruction-types :test #'eq) (setf instruction-in-delay-slot-p t)) (t (setf instruction-in-delay-slot-p nil)))))) ;;;; Disassemble-code-sap (defun disassemble-code-sap (sap length &optional (stream t)) (do ((*current-instruction-number* 0 (1+ *current-instruction-number*)) (instruction-in-delay-slot-p nil)) ((>= *current-instruction-number* length)) (unless instruction-in-delay-slot-p (format stream "~6D:" *current-instruction-number*)) (multiple-value-bind (name type) (disassemble-instruction (system:sap-ref-32 sap *current-instruction-number*) stream) (declare (ignore name)) (cond ((member type delay-slot-instruction-types :test #'eq) (setf instruction-in-delay-slot-p t)) (t (setf instruction-in-delay-slot-p nil)))))) ;;;; Disassemble (defun compile-function-lambda-expr (function) (multiple-value-bind (lambda closurep name) (function-lambda-expression function) (declare (ignore name)) (when closurep (error "Cannot compile lexical closure.")) (compile nil lambda))) (defun disassemble (object &optional (stream *standard-output*)) (let* ((function (cond ((or (symbolp object) (and (listp object) (eq (car object) 'lisp:setf))) (let ((temp (fdefinition object))) (if (eval:interpreted-function-p temp) (compile-function-lambda-expr temp) temp))) ((eval:interpreted-function-p object) (compile-function-lambda-expr object)) ((functionp object) object) ((and (listp object) (eq (car object) 'lisp::lambda)) (compile nil object)) (t (error "Invalid argument to disassemble - ~S" object)))) (self (system:%primitive function-self function)) (code (di::function-code-header self))) (disassemble-code-sap (truly-the system:system-area-pointer (system:%primitive code-instructions code)) (system:%primitive code-code-size code) stream))) cmucl-21a/src/code/pmax-machdef.lisp000066400000000000000000000022261260377556400175070ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Mach -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pmax-machdef.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Record definitions needed for the interface to Mach. ;;; (in-package "MACH") (intl:textdomain "cmucl") (export '(sigcontext-onstack sigcontext-mask sigcontext-pc sigcontext-regs sigcontext-mdlo sigcontext-mdhi sigcontext-ownedfp sigcontext-fpregs sigcontext-fpc_csr sigcontext-fpc_eir sigcontext-cause sigcontext-badvaddr sigcontext-badpaddr sigcontext *sigcontext indirect-*sigcontext)) (def-c-record sigcontext (onstack unsigned-long) (mask unsigned-long) (pc system-area-pointer) (regs int-array) (mdlo unsigned-long) (mdhi unsigned-long) (ownedfp unsigned-long) (fpregs int-array) (fpc_csr unsigned-long) (fpc_eir unsigned-long) (cause unsigned-long) (badvaddr system-area-pointer) (badpaddr system-area-pointer)) cmucl-21a/src/code/pmax-vm.lisp000066400000000000000000000140571260377556400165470ustar00rootroot00000000000000;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pmax-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; $Header: src/code/pmax-vm.lisp $ ;;; ;;; This file contains the PMAX specific runtime stuff. ;;; (in-package "MIPS") (use-package "SYSTEM") (use-package "ALIEN") (use-package "C-CALL") (intl:textdomain "cmucl") (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution)) ;;;; The sigcontext structure. (def-alien-type unix:sigcontext (struct nil (sc-onstack unsigned-long) (sc-mask unsigned-long) (sc-pc system-area-pointer) (sc-regs (array unsigned-long 32)) (sc-mdlo unsigned-long) (sc-mdhi unsigned-long) (sc-ownedfp unsigned-long) (sc-fpregs (array unsigned-long 32)) (sc-fpc-csr unsigned-long) (sc-fpc-eir unsigned-long) (sc-cause unsigned-long) (sc-badvaddr system-area-pointer) (sc-badpaddr system-area-pointer))) ;;;; Add machine specific features to *features* (pushnew :decstation-3100 *features*) (pushnew :pmax *features*) ;;;; MACHINE-TYPE and MACHINE-VERSION (defun machine-type () "Returns a string describing the type of the local machine." "DECstation") (defun machine-version () "Returns a string describing the version of the local machine." "DECstation") ;;; FIXUP-CODE-OBJECT -- Interface ;;; (defun fixup-code-object (code offset fixup kind) (unless (zerop (rem offset word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (system:without-gcing (let ((sap (truly-the system-area-pointer (%primitive c::code-instructions code)))) (ecase kind (:jump (assert (zerop (ash fixup -26))) (setf (ldb (byte 26 0) (system:sap-ref-32 sap offset)) (ash fixup -2))) (:lui (setf (sap-ref-16 sap offset) (+ (ash fixup -16) (if (logbitp 15 fixup) 1 0)))) (:addi (setf (sap-ref-16 sap offset) (ldb (byte 16 0) fixup))))))) ;;;; Internal-error-arguments. ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((pc (slot scp 'sc-pc))) (declare (type system-area-pointer pc)) (when (logbitp 31 (slot scp 'sc-cause)) (setf pc (sap+ pc 4))) (when (= (sap-ref-8 pc 4) 255) (setf pc (sap+ pc 1))) (let* ((length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-from-system-area pc (* vm:byte-bits 5) vector (* vm:word-bits vm:vector-data-offset) (* length vm:byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) (loop (when (>= index length) (return)) (sc-offsets (c::read-var-integer vector index))) (values error-number (sc-offsets)))))))) ;;;; Sigcontext access functions. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. ;;; (defun sigcontext-program-counter (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot scp 'sc-pc))) ;;; SIGCONTEXT-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; (defun sigcontext-register (scp index) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (deref (slot scp 'sc-regs) index))) (defun %set-sigcontext-register (scp index new) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (setf (deref (slot scp 'sc-regs) index) new) new)) (defsetf sigcontext-register %set-sigcontext-register) ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface. ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; (defun sigcontext-float-register (scp index format) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (system:sap-ref-single sap (* index vm:word-bytes))) (double-float (system:sap-ref-double sap (* index vm:word-bytes))))))) ;;; (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot scp 'sc-fpregs)))) (ecase format (single-float (setf (sap-ref-single sap (* index vm:word-bytes)) new-value)) (double-float (setf (sap-ref-double sap (* index vm:word-bytes)) new-value)))))) ;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; ;;; Given a sigcontext pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot scp 'sc-fpc-csr))) ;;; EXTERN-ALIEN-NAME -- interface. ;;; ;;; The loader uses this to convert alien names to the form they occure in ;;; the symbol table (for example, prepending an underscore). On the MIPS, ;;; we don't do anything. ;;; (defun extern-alien-name (name) (declare (type simple-base-string name)) name) ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; ;;; Do whatever is necessary to make the given code component executable. ;;; (defun sanctify-for-execution (component) (declare (ignore component)) nil) cmucl-21a/src/code/ppc-vm.lisp000066400000000000000000000272121260377556400163610ustar00rootroot00000000000000;;; -*- Package: PPC -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: src/code/ppc-vm.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains the PPC specific runtime stuff. ;;; (in-package "PPC") (use-package "SYSTEM") (intl:textdomain "cmucl-ppc-vm") (eval-when (:compile-toplevel :load-toplevel :execute) (export '(fixup-code-object internal-error-arguments sigcontext-program-counter sigcontext-register sigcontext-float-register sigcontext-floating-point-modes extern-alien-name sanctify-for-execution sigcontext-lr)) ) ;;;; The sigcontext structure. ;;;; Note that the layout of this thing matches the word offsets PT_xxx, not ;;;; (necessarily) the pt_regs structure. #-darwin (def-alien-type sigcontext-regs (struct nil (regs (array unsigned-long 32)) (pc system-area-pointer) (msr unsigned-long) (orig-r3 unsigned-long) (ctr unsigned-long) (lr unsigned-long) (xer unsigned-long) (ccr unsigned-long) (mq unsigned-long) (trap unsigned-long) (dar unsigned-long) (dsisr unsigned-long) (result unsigned-long) (pad (array unsigned-long 4)) (fpregs (array unsigned-long 64)) (pad2 unsigned-long) (fpscr unsigned-long))) ;; In reality on darwin this is an instance of struct mcontext, which ;; contains 4 sub-structures, all defined in mach/thread_status.h. ;; For our purposes we just combine this into one structure, defining ;; types and layout as we see fit. #+darwin (def-alien-type sigcontext-regs (struct nil (dar unsigned-long) (dsisr unsigned-long) (exception unsigned-long) (pad1 unsigned-long) (pad2 (array unsigned-long 4)) (pc system-area-pointer) (msr unsigned-long) (regs (array unsigned-long 32)) (cr unsigned-long) (xer unsigned-long) (lr unsigned-long) (ctr unsigned-long) (mq unsigned-long) (vrsave unsigned-long) (fpregs (array unsigned-long 64)) (pad3 unsigned-long) (fpscr unsigned-long) (vrregs (array unsigned-long 128)) (vscr (array unsigned-long 4)) (pad4 (array unsigned-long 4)) (vrvalid unsigned-long) (pad5 (array unsigned-long 7)))) #-darwin (def-alien-type unix:sigcontext (struct nil (sc-unused (array unsigned-long 4)) (sc-signal int) (sc-handler unsigned-long) (sc-oldmask unsigned-long) (sc-regs (* sigcontext-regs)))) ;; Use the ucontext_t structure for Darwin #+darwin (def-alien-type unix:sigcontext (struct nil (sc-onstack int) (sc-mask int) (sc-ss-sp int) (sc-ss-size int) (sc-ss-flags int) (sc-link int) (sc-mcsize int) (sc-regs (* sigcontext-regs)))) ;;;; Add machine specific features to *features* (pushnew :ppc *features*) ;;;; MACHINE-TYPE and MACHINE-VERSION (defun machine-type () "Returns a string describing the type of the local machine." "PowerPC") (defun machine-version () "Returns a string describing the version of the local machine." "who-knows?") ;;; FIXUP-CODE-OBJECT -- Interface ;;; (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (unless (zerop (rem offset ppc:word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (system:without-gcing (let ((sap (truly-the system-area-pointer (%primitive c::code-instructions code)))) (ecase kind (:b (error "Can't deal with CALL fixups, yet.")) (:ba (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) (ash fixup -2))) (:ha (let* ((h (ldb (byte 16 16) fixup)) (l (ldb (byte 16 0) fixup))) ; Compensate for possible sign-extension when the low half ; is added to the high. We could avoid this by ORI-ing ; the low half in 32-bit absolute loads, but it'd be ; nice to be able to do: ; lis rX,foo@ha ; lwz rY,foo@l(rX) ; and lwz/stw and friends all use a signed 16-bit offset. (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) (:l (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) (ldb (byte 16 0) fixup))))))) ;;;; Internal-error-arguments. ;;; INTERNAL-ERROR-ARGUMENTS -- interface. ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. ;;; (defun internal-error-arguments (scp) (declare (type (alien (* unix:sigcontext)) scp)) (let* ((pc (with-alien ((scp (* unix:sigcontext) scp)) (slot (slot scp 'sc-regs) 'pc))) (bad-inst (sap-ref-32 pc 0)) (op (ldb (byte 16 16) bad-inst))) (declare (type system-area-pointer pc)) (cond ((= op (logior (ash 3 10) (ash 6 5))) (args-for-unimp-inst scp)) ((and (= (ldb (byte 6 10) op) 3) (= (ldb (byte 5 5) op) 24)) (let* ((regnum (ldb (byte 5 0) op)) (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0))) (if (and (= (ldb (byte 6 26) prev) 3) (= (ldb (byte 5 21) prev) 0)) (values (ldb (byte 16 0) prev) (list (c::make-sc-offset ppc:any-reg-sc-number (ldb (byte 5 16) prev)))) (values #.(kernel:error-number-or-lose 'kernel:invalid-argument-count-error) (list (c::make-sc-offset ppc:any-reg-sc-number regnum)))))) (t (values #.(error-number-or-lose 'unknown-error) nil))))) (defun args-for-unimp-inst (scp) (declare (type (alien (* unix:sigcontext)) scp)) (let* ((pc (with-alien ((scp (* unix:sigcontext) scp)) (slot (slot scp 'sc-regs) 'pc))) (length (sap-ref-8 pc 4)) (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type system-area-pointer pc) (type (unsigned-byte 8) length) (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-from-system-area pc (* ppc:byte-bits 5) vector (* ppc:word-bits ppc:vector-data-offset) (* length ppc:byte-bits)) (let* ((index 0) (error-number (c::read-var-integer vector index))) (collect ((sc-offsets)) (loop (when (>= index length) (return)) (sc-offsets (c::read-var-integer vector index))) (values error-number (sc-offsets)))))) ;;;; Sigcontext access functions. ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface. ;;; (defun sigcontext-program-counter (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot (slot scp 'sc-regs) 'pc))) ;;; SIGCONTEXT-REGISTER -- Interface. ;;; ;;; An escape register saves the value of a register for a frame that someone ;;; interrupts. ;;; (defun sigcontext-register (scp index) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (deref (slot (slot scp 'sc-regs) 'regs) index))) (defun %set-sigcontext-register (scp index new) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (setf (deref (slot (slot scp 'sc-regs) 'regs) index) new) new)) (defsetf sigcontext-register %set-sigcontext-register) ;; Extract the LR register from the sigcontext. (defun sigcontext-lr (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot (slot scp 'sc-regs) 'lr))) ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface ;;; ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register. ;;; Format is the type of float to return. ;;; (defun sigcontext-float-register (scp index format) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot (slot scp 'sc-regs) 'fpregs)))) (ecase format (single-float (float (system:sap-ref-double sap (* index 2 ppc:word-bytes)) 0.0f0)) (double-float (system:sap-ref-double sap (* index 2 ppc:word-bytes))))))) ;;; (defun %set-sigcontext-float-register (scp index format new-value) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (let ((sap (alien-sap (slot (slot scp 'sc-regs) 'fpregs)))) (ecase format (single-float (setf (sap-ref-double sap (* index 2 ppc:word-bytes)) (coerce new-value 'double-float))) (double-float (setf (sap-ref-double sap (* index 2 ppc:word-bytes)) new-value)))))) ;;; (defsetf sigcontext-float-register %set-sigcontext-float-register) ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface ;;; ;;; Given a sigcontext pointer, return the floating point modes word in the ;;; same format as returned by FLOATING-POINT-MODES. ;;; (defun sigcontext-floating-point-modes (scp) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (slot (slot scp 'sc-regs) 'fpscr))) (defun %set-sigcontext-floating-point-modes (scp new-value) (declare (type (alien (* unix:sigcontext)) scp)) (with-alien ((scp (* unix:sigcontext) scp)) (setf (slot (slot scp 'sc-regs) 'fpscr) new-value))) (defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes) ;;; EXTERN-ALIEN-NAME -- interface. ;;; ;;; The loader uses this to convert alien names to the form they occure in ;;; the symbol table (for example, prepending an underscore). On the SPARC, ;;; we prepend an underscore. ;;; (defun extern-alien-name (name) (declare (type simple-base-string name)) (concatenate 'simple-base-string "_" name)) #-linkage-table (defun lisp::foreign-symbol-address-aux (name flavor) (declare (ignore flavor)) (multiple-value-bind (value found) (gethash name lisp::*foreign-symbols* 0) (if found value (multiple-value-bind (value found) (gethash (concatenate 'string "ldso_stub__" name) lisp::*foreign-symbols* 0) (if found value (let ((value (system:alternate-get-global-address name))) (when (zerop value) (error "Unknown foreign symbol: ~S" name)) value)))))) #+linkage-table (progn (defun lisp::foreign-symbol-address-aux (name flavor) (let ((entry-num (lisp::register-foreign-linkage name flavor))) (+ #.vm:target-foreign-linkage-space-start (* entry-num vm:target-foreign-linkage-entry-size)))) (defun lisp::find-foreign-symbol (addr) (declare (type (unsigned-byte 32) addr)) (when (>= addr vm:target-foreign-linkage-space-start) (let ((entry (/ (- addr vm:target-foreign-linkage-space-start) vm:target-foreign-linkage-entry-size))) (when (< entry (lisp::foreign-linkage-symbols)) (lisp::foreign-linkage-entry entry))))) ) ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; ;;; Do whatever is necessary to make the given code component executable. ;;; On the 601, we have less to do than on some other PowerPC chips. ;;; This should what needs to be done in the general case. ;;; (defun sanctify-for-execution (component) (without-gcing (alien-funcall (extern-alien "ppc_flush_icache" (function void system-area-pointer unsigned-long)) (code-instructions component) (* (code-header-ref component code-code-size-slot) word-bytes))) nil) ;;; Enable/Disable scavenging of the read-only space. (defvar *scavenge-read-only-space* nil) ;; Not really necessary (AFAICT), but nice to have around. The ;; compiler will normally use vops to implement these functions. (defun fused-multiply-subtract (x y z) "Compute x*y-z with only one rounding operation" (declare (double-float x y z)) (fused-multiply-subtract x y z)) (defun fused-multiply-add (x y z) "Compute x*y+z with only one rounding operation" (declare (double-float x y z)) (fused-multiply-add x y z)) cmucl-21a/src/code/pprint-loop.lisp000066400000000000000000000154201260377556400174400ustar00rootroot00000000000000;;; -*- Mode: lisp; Package: PRETTY-PRINT -*- ;;; Pretty printer for loop and various other utilities. ;;; This is taken from Dick Water's XP. The license contained therein says: ;;; ;;; Permission to use, copy, modify, and distribute this software and its ;;; documentation for any purpose and without fee is hereby granted, ;;; provided that this copyright and permission notice appear in all ;;; copies and supporting documentation, and that the name of M.I.T. not ;;; be used in advertising or publicity pertaining to distribution of the ;;; software without specific, written prior permission. M.I.T. makes no ;;; representations about the suitability of this software for any ;;; purpose. It is provided "as is" without express or implied warranty. ;;; ;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;; SOFTWARE. ;; The challenge here is that we have to effectively parse the clauses ;; of the loop in order to know how to print things. Also you want to ;; do this in a purely incremental way so that all of the abbreviation ;; things work, and you wont blow up on circular lists or the like. ;; (More aesthic output could be produced by really parsing the ;; clauses into nested lists before printing them.) ;; ;; The following program assumes the following simplified grammar of ;; the loop clauses that explains how to print them. Note that it ;; does not bare much resemblence to the right parsing grammar, ;; however, it produces half decent output. The way to make the ;; output better is to make the grammar more detailed. ;; ;; loop == (LOOP {clause}*) ;one clause on each line. ;; clause == block | linear | cond | finally ;; block == block-head {expr}* ;as many exprs as possible on each line. ;; linear == linear-head {expr}* ;one expr on each line. ;; finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. ;; cond == cond-head [expr] ;; clause ;; {AND clause}* ;one AND on each line. ;; [ELSE ;; clause ;; {AND clause}*] ;one AND on each line. ;; [END] ;; block-head == FOR | AS | WITH | AND ;; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN ;; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT ;; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING ;; linear-head == DO | DOING | INITIALLY ;; var-head == FOR | AS | WITH ;; cond-head == IF | WHEN | UNLESS ;; expr == ;; ;; Note all the string comparisons below are required to support some ;; existing implementations of LOOP. (in-package "PRETTY-PRINT") (intl:textdomain "cmucl") (defun pprint-loop-token-type (token &aux string) (cond ((not (symbolp token)) :expr) ((string= (setq string (string token)) "FINALLY") :finally) ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head) ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head) ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE" "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER" "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING" "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING") :test #'string=) :block-head) (T :expr))) (defun pprint-loop (xp loop) (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop (funcall (formatter "~:<~W~^~2I~@:_~@{~W~^~_~}~:>") xp loop) (progn (pprint-logical-block (xp loop :prefix "(" :suffix ")") (let (token type) (labels ((next-token () (pprint-exit-if-list-exhausted) (setq token (pprint-pop)) (setq type (pprint-loop-token-type token))) (print-clause (xp) (case type (:linear-head (print-exprs xp nil :mandatory)) (:cond-head (print-cond xp)) (:finally (print-exprs xp T :mandatory)) (otherwise (print-exprs xp nil :fill)))) (print-exprs (xp skip-first-non-expr newline-type) (let ((first token)) (next-token) ;so always happens no matter what (pprint-logical-block (xp nil) (write first :stream xp) (when (and skip-first-non-expr (not (eq type :expr))) (write-char #\space xp) (write token :stream xp) (next-token)) (when (eq type :expr) (write-char #\space xp) (pprint-indent :current 0 xp) (loop (write token :stream xp) (next-token) (when (not (eq type :expr)) (return nil)) (write-char #\space xp) (pprint-newline newline-type xp)))))) (print-cond (xp) (let ((first token)) (next-token) ;so always happens no matter what (pprint-logical-block (xp nil) (write first :stream xp) (when (eq type :expr) (write-char #\space xp) (write token :stream xp) (next-token)) (write-char #\space xp) (pprint-indent :block 2 xp) (pprint-newline :linear xp) (print-clause xp) (print-and-list xp) (when (and (symbolp token) (string= (string token) "ELSE")) (print-else-or-end xp) (write-char #\space xp) (pprint-newline :linear xp) (print-clause xp) (print-and-list xp)) (when (and (symbolp token) (string= (string token) "END")) (print-else-or-end xp))))) (print-and-list (xp) (loop (when (not (and (symbolp token) (string= (string token) "AND"))) (return nil)) (write-char #\space xp) (pprint-newline :mandatory xp) (write token :stream xp) (next-token) (write-char #\space xp) (print-clause xp))) (print-else-or-end (xp) (write-char #\space xp) (pprint-indent :block 0 xp) (pprint-newline :linear xp) (write token :stream xp) (next-token) (pprint-indent :block 2 xp))) ;;(pprint-exit-if-list-exhausted) (write (pprint-pop) :stream xp) (next-token) (write-char #\space xp) (pprint-indent :current 0 xp) (loop (print-clause xp) (write-char #\space xp) (pprint-newline :linear xp)))))))) ;;; LOOP-PP-INIT -- interface ;;; ;;; This is called by PPRINT-INIT. This enables the pretty printer ;;; for loops. We need this so that loop pprinter is enabled at the ;;; right time, since this is in a file separate from pprint.lisp. ;;; (defun loop-pp-init () (set-pprint-dispatch '(cons (eql loop)) #'pprint-loop)) cmucl-21a/src/code/pprint.lisp000066400000000000000000002101611260377556400164700ustar00rootroot00000000000000;;; -*- Package: PRETTY-PRINT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pprint.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; CMU Common Lisp pretty printer. ;;; Written by William Lott. Algorithm stolen from Richard Waters' XP. ;;; (in-package "PRETTY-PRINT") (use-package "EXT") (use-package "KERNEL") (intl:textdomain "cmucl") (export '(pretty-stream pretty-stream-p)) (in-package "LISP") (export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted pprint-newline pprint-indent pprint-tab pprint-fill pprint-linear pprint-tabular copy-pprint-dispatch pprint-dispatch set-pprint-dispatch)) (in-package "PP") ;;;; Pretty streams ;;; There are three different units for measuring character positions: ;;; COLUMN - offset (if characters) from the start of the current line. ;;; INDEX - index into the output buffer. ;;; POSN - some position in the stream of characters cycling through ;;; the output buffer. ;;; (deftype column () '(and fixnum unsigned-byte)) ;;; The INDEX type is picked up from the kernel package. (deftype posn () 'fixnum) (defconstant initial-buffer-size 128) (defconstant default-line-length 80) (defstruct (pretty-stream (:include sys:lisp-stream (:out #'pretty-out) (:sout #'pretty-sout) (:misc #'pretty-misc)) (:constructor make-pretty-stream (target)) (:print-function %print-pretty-stream)) ;; ;; Where the output is going to finally go. ;; (target (required-argument) :type stream) ;; ;; Line length we should format to. Cached here so we don't have to keep ;; extracting it from the target stream. (line-length (or *print-right-margin* (lisp::line-length target) default-line-length) :type column) ;; ;; A simple string holding all the text that has been output but not yet ;; printed. (buffer (make-string initial-buffer-size) :type simple-string) ;; ;; The index into BUFFER where more text should be put. (buffer-fill-pointer 0 :type index) ;; ;; Whenever we output stuff from the buffer, we shift the remaining noise ;; over. This makes it difficult to keep references to locations in ;; the buffer. Therefore, we have to keep track of the total amount of ;; stuff that has been shifted out of the buffer. (buffer-offset 0 :type posn) ;; ;; The column the first character in the buffer will appear in. Normally ;; zero, but if we end up with a very long line with no breaks in it we ;; might have to output part of it. Then this will no longer be zero. (buffer-start-column (or (lisp::charpos target) 0) :type column) ;; ;; The line number we are currently on. Used for *print-lines* abrevs and ;; to tell when sections have been split across multiple lines. (line-number 0 :type index) ;; ;; Stack of logical blocks in effect at the buffer start. (blocks (list (make-logical-block)) :type list) ;; ;; Buffer holding the per-line prefix active at the buffer start. ;; Indentation is included in this. The length of this is stored ;; in the logical block stack. (prefix (make-string initial-buffer-size) :type simple-string) ;; ;; Buffer holding the total remaining suffix active at the buffer start. ;; The characters are right-justified in the buffer to make it easier ;; to output the buffer. The length is stored in the logical block ;; stack. (suffix (make-string initial-buffer-size) :type simple-string) ;; ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) ;; cons. Adding things to the queue is basically (setf (cdr head) (list ;; new)) and removing them is basically (pop tail) [except that care must ;; be taken to handle the empty queue case correctly.] (queue-tail nil :type list) (queue-head nil :type list) ;; ;; Block-start queue entries in effect at the queue head. (pending-blocks nil :type list) ;; ;; Queue of annotations to the buffer (annotations-tail nil :type list) (annotations-head nil :type list)) (defun %print-pretty-stream (pstream stream depth) (declare (ignore depth)) #+nil (print-unreadable-object (pstream stream :type t :identity t)) (format stream "#" (kernel:get-lisp-obj-address pstream))) (declaim (inline index-posn posn-index posn-column)) (defun index-posn (index stream) (declare (type index index) (type pretty-stream stream) (values posn)) (+ index (pretty-stream-buffer-offset stream))) (defun posn-index (posn stream) (declare (type posn posn) (type pretty-stream stream) (values index)) (- posn (pretty-stream-buffer-offset stream))) (defun posn-column (posn stream) (declare (type posn posn) (type pretty-stream stream) (values posn)) (index-column (posn-index posn stream) stream)) ;;;; Stream interface routines. (defun pretty-out (stream char) (declare (type pretty-stream stream) (type base-char char)) (cond ((char= char #\newline) (enqueue-newline stream :literal)) (t (assure-space-in-buffer stream 1) (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream))) (setf (schar (pretty-stream-buffer stream) fill-pointer) char) (setf (pretty-stream-buffer-fill-pointer stream) (1+ fill-pointer)))))) (defun pretty-sout (stream string start end) (declare (type pretty-stream stream) (type simple-string string) (type index start) (type (or index null) end)) (let ((end (or end (length string)))) (unless (= start end) (let ((newline (position #\newline string :start start :end end))) (cond (newline (pretty-sout stream string start newline) (enqueue-newline stream :literal) (pretty-sout stream string (1+ newline) end)) (t (let ((chars (- end start))) (loop (let* ((available (assure-space-in-buffer stream chars)) (count (min available chars)) (fill-pointer (pretty-stream-buffer-fill-pointer stream)) (new-fill-ptr (+ fill-pointer count))) (replace (pretty-stream-buffer stream) string :start1 fill-pointer :end1 new-fill-ptr :start2 start) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) (decf chars count) (when (zerop count) (return)) (incf start count)))))))))) (defun pretty-misc (stream op &optional arg1 arg2) (declare (ignore stream op arg1 arg2))) ;;;; Logical blocks. (defstruct logical-block ;; ;; The column this logical block started in. (start-column 0 :type column) ;; ;; The column the current section started in. (section-column 0 :type column) ;; ;; The length of the per-line prefix. We can't move the indentation ;; left of this. (per-line-prefix-end 0 :type index) ;; ;; The overall length of the prefix, including any indentation. (prefix-length 0 :type index) ;; ;; The overall length of the suffix. (suffix-length 0 :type index) ;; ;; The line number (section-start-line 0 :type index)) (defun really-start-logical-block (stream column prefix suffix) (let* ((blocks (pretty-stream-blocks stream)) (prev-block (car blocks)) (per-line-end (logical-block-per-line-prefix-end prev-block)) (prefix-length (logical-block-prefix-length prev-block)) (suffix-length (logical-block-suffix-length prev-block)) (block (make-logical-block :start-column column :section-column column :per-line-prefix-end per-line-end :prefix-length prefix-length :suffix-length suffix-length :section-start-line (pretty-stream-line-number stream)))) (setf (pretty-stream-blocks stream) (cons block blocks)) (set-indentation stream column) (when prefix (setf (logical-block-per-line-prefix-end block) column) (replace (pretty-stream-prefix stream) prefix :start1 (- column (length prefix)) :end1 column)) (when suffix (let* ((total-suffix (pretty-stream-suffix stream)) (total-suffix-len (length total-suffix)) (additional (length suffix)) (new-suffix-len (+ suffix-length additional))) (when (> new-suffix-len total-suffix-len) (let ((new-total-suffix-len (max (* total-suffix-len 2) (+ suffix-length (floor (* additional 5) 4))))) (setf total-suffix (replace (make-string new-total-suffix-len) total-suffix :start1 (- new-total-suffix-len suffix-length) :start2 (- total-suffix-len suffix-length))) (setf total-suffix-len new-total-suffix-len) (setf (pretty-stream-suffix stream) total-suffix))) (replace total-suffix suffix :start1 (- total-suffix-len new-suffix-len) :end1 (- total-suffix-len suffix-length)) (setf (logical-block-suffix-length block) new-suffix-len)))) nil) (defun set-indentation (stream column) (let* ((prefix (pretty-stream-prefix stream)) (prefix-len (length prefix)) (block (car (pretty-stream-blocks stream))) (current (logical-block-prefix-length block)) (minimum (logical-block-per-line-prefix-end block)) (column (max minimum column))) (when (> column prefix-len) (setf prefix (replace (make-string (max (* prefix-len 2) (+ prefix-len (floor (* (- column prefix-len) 5) 4)))) prefix :end1 current)) (setf (pretty-stream-prefix stream) prefix)) (when (> column current) (fill prefix #\space :start current :end column)) (setf (logical-block-prefix-length block) column))) (defun really-end-logical-block (stream) (let* ((old (pop (pretty-stream-blocks stream))) (old-indent (logical-block-prefix-length old)) (new (car (pretty-stream-blocks stream))) (new-indent (logical-block-prefix-length new))) (when (> new-indent old-indent) (fill (pretty-stream-prefix stream) #\space :start old-indent :end new-indent))) nil) ;;;; The pending operation queue. (defstruct queued-op (posn 0 :type posn)) (defmacro enqueue (stream type &rest args) (let ((constructor (intern (concatenate 'string "MAKE-" (symbol-name type))))) (once-only ((stream stream) (entry `(,constructor :posn (index-posn (pretty-stream-buffer-fill-pointer ,stream) ,stream) ,@args)) (op `(list ,entry)) (head `(pretty-stream-queue-head ,stream))) `(progn (if ,head (setf (cdr ,head) ,op) (setf (pretty-stream-queue-tail ,stream) ,op)) (setf (pretty-stream-queue-head ,stream) ,op) ,entry)))) (defstruct (section-start (:include queued-op)) (depth 0 :type index) (section-end nil :type (or null newline block-end))) (defstruct (newline (:include section-start)) (kind (required-argument) :type (member :linear :fill :miser :literal :mandatory))) (defun enqueue-newline (stream kind) (let* ((depth (length (pretty-stream-pending-blocks stream))) (newline (enqueue stream newline :kind kind :depth depth))) (dolist (entry (pretty-stream-queue-tail stream)) (when (and (not (eq newline entry)) (section-start-p entry) (null (section-start-section-end entry)) (<= depth (section-start-depth entry))) (setf (section-start-section-end entry) newline)))) (maybe-output stream (or (eq kind :literal) (eq kind :mandatory)))) (defstruct (indentation (:include queued-op)) (kind (required-argument) :type (member :block :current)) (amount 0 :type fixnum)) (defun enqueue-indent (stream kind amount) (enqueue stream indentation :kind kind :amount amount)) (defstruct (block-start (:include section-start)) (block-end nil :type (or null block-end)) (prefix nil :type (or null simple-string)) (suffix nil :type (or null simple-string))) (defun start-logical-block (stream prefix per-line-p suffix &optional prefix-p per-line-prefix-p suffix-p) (declare (type (or null string) prefix suffix)) ;; If a prefix (or per-line-prefix) is explicitly given, it must be ;; a string. (when (and (or prefix-p per-line-prefix-p) (not (stringp prefix))) (error 'type-error :datum prefix :expected-type 'string)) ;; Likewise for a suffix (when (and suffix-p (not (stringp suffix))) (error 'type-error :datum suffix :expected-type 'string)) (let ((p (if prefix (coerce prefix 'simple-string) prefix))) (when prefix (pretty-sout stream p 0 (length p))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) (start (enqueue stream block-start :prefix (and per-line-p p) :suffix (coerce suffix 'simple-string) :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) (cons start pending-blocks))))) (defstruct (block-end (:include queued-op)) (suffix nil :type (or null simple-string))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) (suffix (block-start-suffix start)) (end (enqueue stream block-end :suffix suffix))) (when suffix (pretty-sout stream suffix 0 (length suffix))) (setf (block-start-block-end start) end))) (defstruct (tab (:include queued-op)) (sectionp nil :type (member t nil)) (relativep nil :type (member t nil)) (colnum 0 :type column) (colinc 0 :type column)) (defun enqueue-tab (stream kind colnum colinc) (multiple-value-bind (sectionp relativep) (ecase kind (:line (values nil nil)) (:line-relative (values nil t)) (:section (values t nil)) (:section-relative (values t t))) (enqueue stream tab :sectionp sectionp :relativep relativep :colnum colnum :colinc colinc))) ;;;; Tab support. (defun compute-tab-size (tab section-start column) (let ((origin (if (tab-sectionp tab) section-start 0)) (colnum (tab-colnum tab)) (colinc (tab-colinc tab))) (cond ((tab-relativep tab) (unless (<= colinc 1) (let ((newposn (+ (- column origin) colnum))) (let ((rem (rem newposn colinc))) (unless (zerop rem) (incf colnum (- colinc rem)))))) colnum) ((< column (+ colnum origin)) (- (+ colnum origin) column)) (t (if (zerop colinc) 0 (- colinc (rem (- column origin colnum) colinc))))))) (defun index-column (index stream) (let ((column (pretty-stream-buffer-start-column stream)) (section-start (logical-block-section-column (first (pretty-stream-blocks stream)))) (end-posn (index-posn index stream))) (dolist (op (pretty-stream-queue-tail stream)) (when (>= (queued-op-posn op) end-posn) (return)) (typecase op (tab (incf column (compute-tab-size op section-start (+ column (posn-index (tab-posn op) stream))))) ((or newline block-start) (setf section-start (+ column (posn-index (queued-op-posn op) stream)))))) (+ column index))) (defun expand-tabs (stream through) (let ((insertions nil) (additional 0) (column (pretty-stream-buffer-start-column stream)) (section-start (logical-block-section-column (first (pretty-stream-blocks stream))))) (dolist (op (pretty-stream-queue-tail stream)) (typecase op (tab (let* ((index (posn-index (tab-posn op) stream)) (tabsize (compute-tab-size op section-start (+ column index)))) (unless (zerop tabsize) (push (cons index tabsize) insertions) (incf additional tabsize) (incf column tabsize)))) ((or newline block-start) (setf section-start (+ column (posn-index (queued-op-posn op) stream))))) (when (eq op through) (return))) (when insertions (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) (new-fill-ptr (+ fill-ptr additional)) (buffer (pretty-stream-buffer stream)) (new-buffer buffer) (length (length buffer)) (end fill-ptr)) (when (> new-fill-ptr length) (let ((new-length (max (* length 2) (+ fill-ptr (floor (* additional 5) 4))))) (setf new-buffer (make-string new-length)) (setf (pretty-stream-buffer stream) new-buffer))) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) (decf (pretty-stream-buffer-offset stream) additional) (dolist (insertion insertions) (let* ((srcpos (car insertion)) (amount (cdr insertion)) (dstpos (+ srcpos additional))) (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end) (fill new-buffer #\space :start (- dstpos amount) :end dstpos) (decf additional amount) (setf end srcpos))) (unless (eq new-buffer buffer) (replace new-buffer buffer :end1 end :end2 end)))))) ;;;; Annotations support. (defstruct (annotation (:include queued-op)) (handler (constantly nil) :type function) (record)) (defun enqueue-annotation (stream handler record) "Insert an annotation into the pretty-printing stream STREAM. HANDLER is a function, and RECORD is an arbitrary datum. The pretty-printing stream conceptionally queues annotations in sequence with the characters that are printed to the stream, until the stream has decided on the concrete layout. When the characters are forwarded to the target stream, annotations are invoked at the right position. An annotation is invoked by calling the function HANDLER with the three arguments RECORD, TARGET-STREAM, and TRUNCATEP. The argument TRUNCATEP is true if the text surrounding the annotation is suppressed due to line abbreviation (see *PRINT-LINES*). If STREAM is not a pretty-printing stream, simply call HANDLER with the arguments RECORD, STREAM and nil." (enqueue stream annotation :handler handler :record record)) (defun re-enqueue-annotation (stream annotation) "Insert ANNOTATION into the queue of annotations in STREAM." (let* ((annotation-cons (list annotation)) (head (pretty-stream-annotations-head stream))) (if head (setf (cdr head) annotation-cons) (setf (pretty-stream-annotations-tail stream) annotation-cons)) (setf (pretty-stream-annotations-head stream) annotation-cons))) (defun re-enqueue-annotations (stream end) "Insert all annotations in STREAM from the queue of pending operations into the queue of annotations. When END is non-nil, stop before reaching the queued-op END." #-(and) (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) while (and tail (not (eql (car tail) end))) when (annotation-p (car tail)) do (re-enqueue-annotation stream (car tail))) #+(and) (do ((tail (pretty-stream-queue-tail stream) (cdr tail))) ((not (and tail (not (eql (car tail) end))))) (when (annotation-p (car tail)) (re-enqueue-annotation stream (car tail))))) (defun dequeue-annotation (stream &key end-posn) "Dequeue the next annotation from the queue of annotations of STREAM and return it. Return nil if there are no more annotations. When :END-POSN is given and the next annotation has a posn greater than this, also return nil." (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) (when next-annotation (when (or (not end-posn) (<= (annotation-posn next-annotation) end-posn)) (pop (pretty-stream-annotations-tail stream)) (unless (pretty-stream-annotations-tail stream) (setf (pretty-stream-annotations-head stream) nil)) next-annotation)))) (defun invoke-annotation (stream annotation truncatep) (let ((target (pretty-stream-target stream))) (funcall (annotation-handler annotation) (annotation-record annotation) target truncatep))) (defun output-buffer-with-annotations (stream end) "Output the buffer of STREAM up to (excluding) the buffer index END. When annotations are present, invoke them at the right positions." (let ((target (pretty-stream-target stream)) (buffer (pretty-stream-buffer stream)) (end-posn (index-posn end stream)) (start 0)) #-(and) (loop for annotation = (dequeue-annotation stream :end-posn end-posn) while annotation do (let ((annotation-index (posn-index (annotation-posn annotation) stream))) (write-string buffer target :start start :end annotation-index) (invoke-annotation stream annotation nil) (setf start annotation-index))) #+(and) (do ((annotation (dequeue-annotation stream :end-posn end-posn) (dequeue-annotation stream :end-posn end-posn))) ((not annotation)) (let ((annotation-index (posn-index (annotation-posn annotation) stream))) (write-string buffer target :start start :end annotation-index) (invoke-annotation stream annotation nil) (setf start annotation-index))) (write-string buffer target :start start :end end))) (defun flush-annotations (stream end truncatep) "Invoke all annotations in STREAM up to (including) the buffer index END." (let ((end-posn (index-posn end stream))) #-(and) (loop for annotation = (dequeue-annotation stream :end-posn end-posn) while annotation do (invoke-annotation stream annotation truncatep)) #+(and) (do ((annotation (dequeue-annotation stream :end-posn end-posn) (dequeue-annotation stream :end-posn end-posn))) ((not annotation)) (invoke-annotation stream annotation truncatep)) )) ;;;; Stuff to do the actual outputting. (defun assure-space-in-buffer (stream want) (declare (type pretty-stream stream) (type index want)) (let* ((buffer (pretty-stream-buffer stream)) (length (length buffer)) (fill-ptr (pretty-stream-buffer-fill-pointer stream)) (available (- length fill-ptr))) (cond ((plusp available) available) ((> fill-ptr (pretty-stream-line-length stream)) (unless (maybe-output stream nil) (output-partial-line stream)) (assure-space-in-buffer stream want)) (t (let* ((new-length (max (* length 2) (+ length (floor (* want 5) 4)))) (new-buffer (make-string new-length))) (setf (pretty-stream-buffer stream) new-buffer) (replace new-buffer buffer :end1 fill-ptr) (- new-length fill-ptr)))))) (defun maybe-output (stream force-newlines-p) (declare (type pretty-stream stream)) (let ((tail (pretty-stream-queue-tail stream)) (output-anything nil)) (loop (unless tail (setf (pretty-stream-queue-head stream) nil) (return)) (let ((next (pop tail))) (etypecase next (newline (when (ecase (newline-kind next) ((:literal :mandatory :linear) t) (:miser (misering-p stream)) (:fill (or (misering-p stream) (> (pretty-stream-line-number stream) (logical-block-section-start-line (first (pretty-stream-blocks stream)))) (ecase (fits-on-line-p stream (newline-section-end next) force-newlines-p) ((t) nil) ((nil) t) (:dont-know (return)))))) (setf output-anything t) (output-line stream next))) (indentation (unless (misering-p stream) (set-indentation stream (+ (ecase (indentation-kind next) (:block (logical-block-start-column (car (pretty-stream-blocks stream)))) (:current (posn-column (indentation-posn next) stream))) (indentation-amount next))))) (block-start (ecase (fits-on-line-p stream (block-start-section-end next) force-newlines-p) ((t) ;; Just nuke the whole logical block and make it look like one ;; nice long literal. (But don't nuke annotations.) (let ((end (block-start-block-end next))) (expand-tabs stream end) (re-enqueue-annotations stream end) (setf tail (cdr (member end tail))))) ((nil) (really-start-logical-block stream (posn-column (block-start-posn next) stream) (block-start-prefix next) (block-start-suffix next))) (:dont-know (return)))) (block-end (really-end-logical-block stream)) (tab (expand-tabs stream next)) (annotation (re-enqueue-annotation stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) (defun misering-p (stream) (declare (type pretty-stream stream)) (and *print-miser-width* (<= (- (pretty-stream-line-length stream) (logical-block-start-column (car (pretty-stream-blocks stream)))) *print-miser-width*))) (defun fits-on-line-p (stream until force-newlines-p) (let ((available (pretty-stream-line-length stream))) (when (and (not *print-readably*) *print-lines* (= *print-lines* (pretty-stream-line-number stream))) (decf available 3) ; for the `` ..'' (decf available (logical-block-suffix-length (car (pretty-stream-blocks stream))))) (cond (until (<= (posn-column (queued-op-posn until) stream) available)) (force-newlines-p nil) ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream) available) nil) (t :dont-know)))) (defun output-line (stream until) (declare (type pretty-stream stream) (type newline until)) (let* ((target (pretty-stream-target stream)) (buffer (pretty-stream-buffer stream)) (kind (newline-kind until)) (literal-p (eq kind :literal)) (amount-to-consume (posn-index (newline-posn until) stream)) (amount-to-print (if literal-p amount-to-consume (let ((last-non-blank (position #\space buffer :end amount-to-consume :from-end t :test #'char/=))) (if last-non-blank (1+ last-non-blank) 0))))) (output-buffer-with-annotations stream amount-to-print) (flush-annotations stream amount-to-consume nil) (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) *print-lines* (>= line-number *print-lines*)) (write-string " .." target) (flush-annotations stream (pretty-stream-buffer-fill-pointer stream) t) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) (unless (zerop suffix-length) (let* ((suffix (pretty-stream-suffix stream)) (len (length suffix))) (write-string suffix target :start (- len suffix-length) :end len)))) (throw 'line-limit-abbreviation-happened t)) (setf (pretty-stream-line-number stream) line-number) (write-char #\newline target) (setf (pretty-stream-buffer-start-column stream) 0) (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) (block (first (pretty-stream-blocks stream))) (prefix-len (if literal-p (logical-block-per-line-prefix-end block) (logical-block-prefix-length block))) (shift (- amount-to-consume prefix-len)) (new-fill-ptr (- fill-ptr shift)) (new-buffer buffer) (buffer-length (length buffer))) (when (> new-fill-ptr buffer-length) (setf new-buffer (make-string (max (* buffer-length 2) (+ buffer-length (floor (* (- new-fill-ptr buffer-length) 5) 4))))) (setf (pretty-stream-buffer stream) new-buffer)) (replace new-buffer buffer :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) (replace new-buffer (pretty-stream-prefix stream) :end1 prefix-len) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) (incf (pretty-stream-buffer-offset stream) shift) (unless literal-p (setf (logical-block-section-column block) prefix-len) (setf (logical-block-section-start-line block) line-number)))))) (defun output-partial-line (stream) (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) (tail (pretty-stream-queue-tail stream)) (count (if tail (posn-index (queued-op-posn (car tail)) stream) fill-ptr)) (new-fill-ptr (- fill-ptr count)) (buffer (pretty-stream-buffer stream))) (when (zerop count) (error (intl:gettext "Output-partial-line called when nothing can be output."))) (output-buffer-with-annotations stream count) (incf (pretty-stream-buffer-start-column stream) count) (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) (incf (pretty-stream-buffer-offset stream) count))) (defun force-pretty-output (stream) (maybe-output stream nil) (expand-tabs stream nil) (re-enqueue-annotations stream nil) (output-buffer-with-annotations stream (pretty-stream-buffer-fill-pointer stream))) ;;;; Utilities. ;;; WITH-PRETTY-STREAM -- internal. ;;; (defmacro with-pretty-stream ((stream-var &optional (stream-expression stream-var)) &body body) (let ((flet-name (gensym "WITH-PRETTY-STREAM-"))) `(flet ((,flet-name (,stream-var) ,@body)) (let ((stream ,stream-expression)) (if (pretty-stream-p stream) (,flet-name stream) (catch 'line-limit-abbreviation-happened (let ((stream (make-pretty-stream stream))) (,flet-name stream) (force-pretty-output stream))))) nil))) ;;;; User interface to the pretty printer. (defmacro pprint-logical-block ((stream-symbol object &key (prefix "" prefix-p) (per-line-prefix nil per-line-p) (suffix "" suffix-p)) &body body) "Group some output into a logical block. STREAM-SYMBOL should be either a stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer control variable *PRINT-LEVEL* is automatically handled." (when (and prefix-p per-line-prefix) (error (intl:gettext "Cannot specify both a prefix and a per-line-prefix."))) (multiple-value-bind (stream-var stream-expression) (case stream-symbol ((nil) (values '*standard-output* '*standard-output*)) ((t) (values '*terminal-io* '*terminal-io*)) (t (values stream-symbol (once-only ((stream stream-symbol)) `(case ,stream ((nil) *standard-output*) ((t) *terminal-io*) (t ,stream)))))) (let* ((object-var (if object (gensym) nil)) (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) (pp-pop-name (gensym "PPRINT-POP-")) (body `(descend-into (,stream-var) (let ((,count-name 0)) (declare (type index ,count-name) (ignorable ,count-name)) (start-logical-block ,stream-var ,(if prefix-p prefix per-line-prefix) ,(if per-line-prefix t nil) ,suffix ,prefix-p ,per-line-p ,suffix-p) (block ,block-name (flet ((,pp-pop-name () ,@(when object `((unless (listp ,object-var) (write-string ". " ,stream-var) (output-object ,object-var ,stream-var) (return-from ,block-name nil)))) (when (and (not *print-readably*) (eql ,count-name *print-length*)) (write-string "..." ,stream-var) (return-from ,block-name nil)) ,@(when object `((when (and ,object-var (plusp ,count-name) (check-for-circularity ,object-var nil :logical-block)) (write-string ". " ,stream-var) (output-object ,object-var ,stream-var) (return-from ,block-name nil)))) (incf ,count-name) ,@(if object `((pop ,object-var)) `(nil)))) (declare (ignorable #',pp-pop-name)) (unwind-protect (macrolet ((pprint-pop () '(,pp-pop-name)) (pprint-exit-if-list-exhausted () ,(if object `'(when (null ,object-var) (return-from ,block-name nil)) `'(return-from ,block-name nil)))) ,@body) (end-logical-block ,stream-var)))) )))) (when object (setf body `(let ((,object-var ,object)) (if (listp ,object-var) (with-circularity-detection (,object-var ,stream-var) ,body) (output-object ,object-var ,stream-var))))) `(with-pretty-stream (,stream-var ,stream-expression) ,body)))) (defmacro pprint-exit-if-list-exhausted () "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return if it's list argument is exhausted. Can only be used inside PPRINT-LOGICAL-BLOCK, and only when the LIST argument to PPRINT-LOGICAL-BLOCK is supplied." (error (intl:gettext "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~ PPRINT-LOGICAL-BLOCK."))) (defmacro pprint-pop () "Return the next element from LIST argument to the closest enclosing use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH* and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK. If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing is poped, but the *PRINT-LENGTH* testing still happens." (error (intl:gettext "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))) (defun pprint-newline (kind &optional stream) "Output a conditional newline to STREAM (which defaults to *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do nothing if not. KIND can be one of: :LINEAR - A line break is inserted if and only if the immediatly containing section cannot be printed on one line. :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. (See *PRINT-MISER-WIDTH*.) :FILL - A line break is inserted if and only if either: (a) the following section cannot be printed on the end of the current line, (b) the preceding section was not printed on a single line, or (c) the immediately containing section cannot be printed on one line and miser-style is in effect. :MANDATORY - A line break is always inserted. When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are ommitted from the output and indentation is introduced at the beginning of the next line. (See PPRINT-INDENT.)" (declare (type (member :linear :miser :fill :mandatory) kind) (type (or stream (member t nil)) stream) (values null)) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-newline stream kind))) nil) (defun pprint-indent (relative-to n &optional stream) "Specify the indentation to use in the current logical block if STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing stream and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: :BLOCK - Indent relative to the column the current logical block started on. :CURRENT - Indent relative to the current column. The new indention value does not take effect until the following line break. The indention value is silently truncated to an integer." (declare (type (member :block :current) relative-to) (type real n) (type (or stream (member t nil)) stream) (values null)) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) ;; CMUCL doesn't really support non-fixed-width characters, so ;; we silently truncate the indentation to an integer. (enqueue-indent stream relative-to (truncate n)))) nil) (defun pprint-tab (kind colnum colinc &optional stream) "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing stream, perform tabbing based on KIND, otherwise do nothing. KIND can be one of: :LINE - Tab to column COLNUM. If already past COLNUM tab to the next multiple of COLINC. :SECTION - Same as :LINE, but count from the start of the current section, not the start of the line. :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of COLINC. :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start of the current section, not the start of the line." (declare (type (member :line :section :line-relative :section-relative) kind) (type unsigned-byte colnum colinc) (type (or stream (member t nil)) stream) (values null)) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) (when (and (pretty-stream-p stream) *print-pretty*) (enqueue-tab stream kind colnum colinc))) nil) (defun pprint-fill (stream list &optional (colon? t) atsign?) "Output LIST to STREAM putting :FILL conditional newlines between each element. If COLON? is NIL (defaults to T), then no parens are printed around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL can be used with the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list :prefix (if colon? "(" "") :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :fill stream)))) (defun pprint-linear (stream list &optional (colon? t) atsign?) "Output LIST to STREAM putting :LINEAR conditional newlines between each element. If COLON? is NIL (defaults to T), then no parens are printed around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR can be used with the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list :prefix (if colon? "(" "") :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream)))) (defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize) "Output LIST to STREAM tabbing to the next column that is an even multiple of TABSIZE (which defaults to 16) between each element. :FILL style conditional newlines are also output between each element. If COLON? is NIL (defaults to T), then no parens are printed around the output. ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list :prefix (if colon? "(" "") :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-tab :section-relative 0 (or tabsize 16) stream) (pprint-newline :fill stream)))) ;;;; Pprint-dispatch tables. (defvar *initial-pprint-dispatch*) (defvar *building-initial-table* nil) (defstruct (pprint-dispatch-entry (:print-function %print-pprint-dispatch-entry)) ;; ;; The type specifier for this entry. (type (required-argument) :type t) ;; ;; A function to test to see if an object is of this time. Pretty must ;; just (lambda (obj) (typep object type)) except that we handle the ;; CONS type specially so that (cons (member foo)) works. We don't ;; bother computing this for entries in the CONS hash table, because ;; we don't need it. (test-fn nil :type (or function null)) ;; ;; The priority for this guy. (priority 0 :type real) ;; ;; T iff one of the original entries. (initial-p *building-initial-table* :type (member t nil)) ;; ;; And the associated function. (function (required-argument) :type (or symbol function))) (defun %print-pprint-dispatch-entry (entry stream depth) (declare (ignore depth)) (print-unreadable-object (entry stream :type t) (format stream "Type=~S, priority=~S~@[ [Initial]~]" (pprint-dispatch-entry-type entry) (pprint-dispatch-entry-priority entry) (pprint-dispatch-entry-initial-p entry)))) (defstruct (pprint-dispatch-table (:print-function %print-pprint-dispatch-table)) ;; ;; A list of all the entries (except for CONS entries below) in highest ;; to lowest priority. (entries nil :type list) ;; ;; A hash table mapping things to entries for type specifiers of the ;; form (CONS (MEMBER )). If the type specifier is of this form, ;; we put it in this hash table instead of the regular entries table. (cons-entries (make-hash-table :test #'eql))) (defun %print-pprint-dispatch-table (table stream depth) (declare (ignore depth)) (print-unreadable-object (table stream :type t :identity t))) (defun cons-type-specifier-p (spec) (and (consp spec) (eq (car spec) 'cons) (cdr spec) (null (cddr spec)) (let ((car (cadr spec))) (and (consp car) (let ((carcar (car car))) (or (eq carcar 'member) (eq carcar 'eql))) (cdr car) (null (cddr car)))))) (defun entry< (e1 e2) (declare (type pprint-dispatch-entry e1 e2)) (if (pprint-dispatch-entry-initial-p e1) (if (pprint-dispatch-entry-initial-p e2) (< (pprint-dispatch-entry-priority e1) (pprint-dispatch-entry-priority e2)) t) (if (pprint-dispatch-entry-initial-p e2) nil (< (pprint-dispatch-entry-priority e1) (pprint-dispatch-entry-priority e2))))) (macrolet ((frob (x) `(cons ',x #'(lambda (object) ,x)))) (defvar *precompiled-pprint-dispatch-funs* (list (frob (typep object 'array)) (frob (and (consp object) (and (typep (car object) 'symbol) (typep (car object) '(satisfies fboundp))))) (frob (typep object 'cons))))) (defun compute-test-fn (type) (let ((was-cons nil)) (labels ((compute-test-expr (type object) (if (listp type) (case (car type) (cons (setq was-cons t) (destructuring-bind (&optional (car nil car-p) (cdr nil cdr-p)) (cdr type) `(and (consp ,object) ,@(when car-p `(,(compute-test-expr car `(car ,object)))) ,@(when cdr-p `(,(compute-test-expr cdr `(cdr ,object))))))) (not (destructuring-bind (type) (cdr type) `(not ,(compute-test-expr type object)))) (and `(and ,@(mapcar #'(lambda (type) (compute-test-expr type object)) (cdr type)))) (or `(or ,@(mapcar #'(lambda (type) (compute-test-expr type object)) (cdr type)))) (t `(typep ,object ',type))) `(typep ,object ',type)))) (let ((expr (compute-test-expr type 'object))) (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs* :test #'equal))) ((fboundp 'compile) (compile nil `(lambda (object) ,expr))) (was-cons (warn (intl:gettext "CONS PPRINT dispatch ignored w/o compiler loaded:~% ~S") type) #'(lambda (object) (declare (ignore object)) nil)) (t (let ((ttype (kernel:specifier-type type))) #'(lambda (object) (kernel:%typep object ttype))))))))) (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) (let* ((orig (or table *initial-pprint-dispatch*)) (new (make-pprint-dispatch-table :entries (copy-list (pprint-dispatch-table-entries orig)))) (new-cons-entries (pprint-dispatch-table-cons-entries new))) (maphash #'(lambda (key value) (setf (gethash key new-cons-entries) value)) (pprint-dispatch-table-cons-entries orig)) new)) (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) (let* ((table (or table *initial-pprint-dispatch*)) (cons-entry (and (consp object) (gethash (car object) (pprint-dispatch-table-cons-entries table)))) (entry (dolist (entry (pprint-dispatch-table-entries table) cons-entry) (when (and cons-entry (entry< entry cons-entry)) (return cons-entry)) (when (funcall (pprint-dispatch-entry-test-fn entry) object) (return entry))))) (if entry (values (pprint-dispatch-entry-function entry) t) (values #'(lambda (stream object) (output-ugly-object object stream)) nil)))) (defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation) (when (eq pprint-dispatch *initial-pprint-dispatch*) (cerror "Modify it anyway." 'standard-pprint-dispatch-table-modified-error :operation operation))) (defun set-pprint-dispatch (type function &optional (priority 0) (table *print-pprint-dispatch*)) (declare (type (or null symbol function) function) (type real priority) (type pprint-dispatch-table table)) (assert-not-standard-pprint-dispatch-table table 'set-pprint-dispatch) (if function (if (cons-type-specifier-p type) (setf (gethash (second (second type)) (pprint-dispatch-table-cons-entries table)) (make-pprint-dispatch-entry :type type :priority priority :function function)) (let ((list (delete type (pprint-dispatch-table-entries table) :key #'pprint-dispatch-entry-type :test #'equal)) (entry (make-pprint-dispatch-entry :type type :test-fn (compute-test-fn type) :priority priority :function function))) (do ((prev nil next) (next list (cdr next))) ((null next) (if prev (setf (cdr prev) (list entry)) (setf list (list entry)))) (when (entry< (car next) entry) (if prev (setf (cdr prev) (cons entry next)) (setf list (cons entry next))) (return))) (setf (pprint-dispatch-table-entries table) list))) (if (cons-type-specifier-p type) (remhash (second (second type)) (pprint-dispatch-table-cons-entries table)) (setf (pprint-dispatch-table-entries table) (delete type (pprint-dispatch-table-entries table) :key #'pprint-dispatch-entry-type :test #'equal)))) nil) (defun array-readably-printable-p (array) (and (eq (array-element-type array) t) (let ((zero (position 0 (array-dimensions array))) (number (position 0 (array-dimensions array) :test (complement #'eql) :from-end t))) (or (null zero) (null number) (> zero number))))) ;;;; Standard pretty-printing routines. (defun pprint-array (stream array) (cond ((or (and (null *print-array*) (null *print-readably*)) (stringp array) (bit-vector-p array)) (output-ugly-object array stream)) ((and *print-readably* (not (lisp::array-readably-printable-p array))) (pprint-raw-array stream array)) ((vectorp array) (pprint-vector stream array)) (t (pprint-multi-dim-array stream array)))) (defun pprint-vector (stream vector) (pprint-logical-block (stream nil :prefix "#(" :suffix ")") (dotimes (i (length vector)) (unless (zerop i) (write-char #\space stream) (pprint-newline :fill stream)) (pprint-pop) (output-object (aref vector i) stream)))) (defun pprint-array-contents (stream array) (lisp::with-array-data ((data array) (start) (end)) (declare (ignore end)) (labels ((output-guts (stream index dimensions) (if (null dimensions) (output-object (aref data index) stream) (pprint-logical-block (stream nil :prefix "(" :suffix ")") (let ((dim (car dimensions))) (unless (zerop dim) (let* ((dims (cdr dimensions)) (index index) (step (reduce #'* dims)) (count 0)) (loop (pprint-pop) (output-guts stream index dims) (when (= (incf count) dim) (return)) (write-char #\space stream) (pprint-newline (if dims :linear :fill) stream) (incf index step))))))))) (output-guts stream start (array-dimensions array))))) (defun pprint-multi-dim-array (stream array) (funcall (formatter "#~DA") stream (array-rank array)) (pprint-array-contents stream array)) (defun pprint-raw-array (stream array) (write-string "#A" stream) (pprint-logical-block (stream nil :prefix "(" :suffix ")") (output-object (array-element-type array) stream) (write-char #\Space stream) (pprint-newline :fill stream) (output-object (array-dimensions array) stream) (write-char #\Space stream) (pprint-newline :fill stream) (pprint-array-contents stream array))) (defun pprint-lambda-list (stream lambda-list &rest noise) (declare (ignore noise)) (when (and (consp lambda-list) (member (car lambda-list) lisp::*bq-tokens*)) ;; if this thing looks like a backquoty thing, then we don't want ;; to destructure it, we want to output it straight away. [ this ;; is the exception to the normal processing: if we did this ;; generally we would find lambda lists such as (FUNCTION FOO) ;; being printed as #'FOO ] -- CSR, 2003-12-07 (output-object lambda-list stream) (return-from pprint-lambda-list nil)) (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") (let ((state :required) (first t)) (loop (pprint-exit-if-list-exhausted) (unless first (write-char #\space stream)) (let ((arg (pprint-pop))) (unless first (case arg (&optional (setf state :optional) (pprint-newline :linear stream)) ((&rest &body) (setf state :required) (pprint-newline :linear stream)) (&key (setf state :key) (pprint-newline :linear stream)) (&aux (setf state :optional) (pprint-newline :linear stream)) (t (pprint-newline :fill stream)))) (ecase state (:required (pprint-lambda-list stream arg)) ((:optional :key) (pprint-logical-block (stream arg :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (if (eq state :key) (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :fill stream) (pprint-lambda-list stream (pprint-pop)) (loop (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :fill stream) (output-object (pprint-pop) stream))) (pprint-lambda-list stream (pprint-pop))) (loop (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) (output-object (pprint-pop) stream)))))) (setf first nil))))) (defun pprint-lambda (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") stream list)) (defun pprint-block (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list)) (defun pprint-flet (stream list &rest noise) (declare (ignore noise)) ;; If the second element of the list is not a list, then we don't ;; really have a flet/labels form, so let's just print it as a ;; list. (This happens when the list is the name an flet/labels in a ;; function. (if (listp (second list)) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") stream list) (funcall (formatter "~@:<~{~W~^ ~:_~}~:>") stream list))) (defun pprint-let (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>") stream list)) (defun pprint-progn (stream list &rest noise) (declare (ignore noise)) #+nil (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list) (funcall (formatter "~:<~^~W~1I~@{ ~@:_~W~}~:>") stream list) ) (defun pprint-progv (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") stream list)) (defun pprint-multiple-value-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~5I ~:_~W~^~3I ~:@_~W~1I~@{ ~:@_~W~}~:>") stream list)) (defun pprint-handler-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~3I ~:_~W~1I~@{ ~:@_~W~}~:>") stream list)) (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) (consp (cdr list)) (null (cddr list))) (case (car list) (function (write-string "#'" stream) (output-object (cadr list) stream)) (quote (write-char #\' stream) (output-object (cadr list) stream)) (t (pprint-fill stream list))) (pprint-fill stream list))) (defun pprint-setq (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :miser stream) (if (and (consp (cdr list)) (consp (cddr list))) (loop (pprint-indent :current 2 stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) (pprint-indent :current -2 stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream)) (progn (pprint-indent :current 0 stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) (output-object (pprint-pop) stream))))) (defmacro pprint-tagbody-guts (stream) `(loop (pprint-exit-if-list-exhausted) (write-char #\space ,stream) (let ((form-or-tag (pprint-pop))) (pprint-indent :block (if (atom form-or-tag) 0 1) ,stream) (pprint-newline :linear ,stream) (output-object form-or-tag ,stream)))) (defun pprint-tagbody (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-tagbody-guts stream))) (defun pprint-case (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") stream list)) (defun pprint-cond (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~W~^~1I~:@_~@{~:<~^~W~^~:@_~@{~W~^~:@_~}~:>~^~:@_~}~:>") stream list)) (defun pprint-declare (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; Output "declare" (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :miser stream) (write-char #\space stream) (pprint-indent :current 0 stream) ;; Print out each spec. (loop (let ((spec (pprint-pop))) ;; If the spec begins with TYPE, we indent it so that vars ;; are lined up after the actual type. Otherwise, we just ;; make them all line up after the first symbol of the ;; spec. (pprint-logical-block (stream spec :prefix "(" :suffix ")") (when (eq (car spec) 'type) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :miser stream) (write-char #\space stream)) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :miser stream) (write-char #\space stream) (pprint-indent :current 0 stream) (loop (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :fill stream)))) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream)))) (defun pprint-defun (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~@_~:I~W~^ ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") stream list)) (defun pprint-destructuring-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~3I ~_~:/PP:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") stream list)) (defun pprint-do (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-indent :current 0 stream) (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>") stream (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) (pprint-linear stream (pprint-pop)) (pprint-tagbody-guts stream))) (defun pprint-dolist (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-indent :block 3 stream) (write-char #\space stream) (pprint-newline :fill stream) (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>") stream (pprint-pop)) (pprint-tagbody-guts stream))) (defun pprint-typecase (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>") stream list)) (defun pprint-prog (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :miser stream) (pprint-fill stream (pprint-pop)) (pprint-tagbody-guts stream))) #+nil (defun pprint-function-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") stream list)) (defun pprint-function-call (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) ;; Function name (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :fill stream) (pprint-indent :current 0 stream) ;; Output args. We try to keep keyword/value pairs on the same ;; line. This, of course, doesn't work if the keyword isn't a ;; keyword arg because that will mess up the following stuff if ;; the next arg is really a keyword arg. (loop (let ((arg (pprint-pop))) (output-object arg stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (when (keywordp arg) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream)) (pprint-newline :linear stream))))) (defun pprint-with-like (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~W~^~3I ~:_~W~^~1I~@{ ~@:_~W~}~:>") stream list)) (defun pprint-defstruct (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; DEFSTRUCT (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-indent :block 1 stream) ;; Output name and any options neatly (funcall (formatter "~:<~W~^ ~1I~@:_~@{~:<~W~^ ~:I~W~@{ ~_~W~}~:>~^~@:_~}~:>") stream (pprint-pop)) ;; Output each slot neatly (loop (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream) (funcall (formatter "~:<~W~^~:I ~W~_~@{ ~W~^~@_~}~:>") stream (pprint-pop))))) (defun pprint-defclass (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; DEFCLASS (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-indent :block 2 stream) (write-char #\space stream) ;; Output class-name (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :fill stream) (write-char #\space stream) ;; Output superclasses (funcall (formatter "~W") stream (pprint-pop)) (pprint-indent :block 1 stream) (pprint-newline :mandatory stream) ;; Output slots. We try to output keyword and value on one line together (funcall (formatter "~:<~^~@{~:<~^~W~^ ~:I~@{~W~^ ~W~^~@:_~}~:>~^~@:_~}~:>") stream (pprint-pop)) ;; Output options (loop (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream) (output-object (pprint-pop) stream)))) (defun pprint-defgeneric (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; DEFGENERIC (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-indent :block 2 stream) (write-char #\space stream) ;; Output class-name (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :fill stream) (write-char #\space stream) ;; Output lambda list (pprint-lambda-list stream (pprint-pop)) (pprint-indent :block 1 stream) ;;(pprint-newline :linear stream) ;; Output options and stuff (loop (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream) (let ((option-or-method (pprint-pop))) ;; Try to print the various options neatly. Right now, we ;; just handle :method (cond ((and (consp option-or-method) (eq (car option-or-method) :method)) (flet ((almost-defmethod (stream list) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; :method (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) ;; Print out all qualifiers then the lambda list (loop (let ((qual-or-lambda (pprint-pop))) (write-char #\space stream) (cond ((listp qual-or-lambda) ;; Print out lambda-list (pprint-lambda-list stream qual-or-lambda) (return)) (t (output-object qual-or-lambda stream))) (pprint-exit-if-list-exhausted))) ;; Rest of the forms (pprint-newline :mandatory stream) (pprint-indent :block 0 stream) (loop (write-char #\space stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :linear stream))))) (almost-defmethod stream option-or-method))) (t (output-object option-or-method stream))))))) (defun pprint-defpackage (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~W ~W~I~@{~@:_ ~:<~@{~W~^~:I~@{ ~W~^~:_~}~}~:>~}~:>") stream list)) (defun pprint-defmethod (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; DEFMETHOD (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) ;; Method name (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) ;; Print out method qualifiers, if any (loop (let ((qual-or-lambda (pprint-pop))) (write-char #\space stream) (cond ((listp qual-or-lambda) ;; Print out lambda-list (pprint-lambda-list stream qual-or-lambda) (return)) (t (output-object qual-or-lambda stream))) (pprint-exit-if-list-exhausted))) ;; Rest of the forms (pprint-newline :mandatory stream) (pprint-indent :block 0 stream) (loop (write-char #\space stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :linear stream)))) (defun pprint-restart-case (stream list &rest noise) (declare (ignore noise)) (pprint-logical-block (stream list :prefix "(" :suffix ")") ;; RESTART-CASE (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (write-char #\space stream) ;; restartable form (output-object (pprint-pop) stream) (pprint-indent :block 1 stream) ;; Output each clause (loop (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream) (destructuring-bind (case-name lambda-list &rest forms) (pprint-pop) (pprint-logical-block (stream forms :prefix "(" :suffix ")") ;; case-name (output-object case-name stream) (write-char #\space stream) ;; lambda-list (pprint-lambda-list stream lambda-list) ;;(pprint-newline :mandatory stream) (pprint-exit-if-list-exhausted) (loop (write-char #\space stream) (output-object (pprint-pop) stream) (pprint-exit-if-list-exhausted) (pprint-newline :linear stream))))))) (defun pprint-when (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>") stream list)) ;;;; Interface seen by regular (ugly) printer and initialization routines. ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is ;;; bound to T. ;;; (defun output-pretty-object (object stream) (with-pretty-stream (stream) (funcall (pprint-dispatch object) stream object))) (defparameter *magic-forms* '((lambda pprint-lambda) ;; Special forms. (block pprint-block) (catch pprint-block) (compiler-let pprint-let) (eval-when pprint-block) (flet pprint-flet) (function pprint-quote) (labels pprint-flet) (let pprint-let) (let* pprint-let) (locally pprint-progn) (macrolet pprint-flet) (multiple-value-call pprint-block) (multiple-value-prog1 pprint-block) (progn pprint-progn) (progv pprint-progv) (quote pprint-quote) (return-from pprint-block) (setq pprint-setq) (symbol-macrolet pprint-let) (tagbody pprint-tagbody) (throw pprint-block) (unwind-protect pprint-block) (declare pprint-declare) ;; Macros. (case pprint-case) (ccase pprint-case) (cond pprint-cond) (ctypecase pprint-typecase) (defconstant pprint-block) (define-condition pprint-defclass) (define-modify-macro pprint-defun) (define-setf-expander pprint-defun) (defmacro pprint-defun) (defpackage pprint-defpackage) (defparameter pprint-block) (defsetf pprint-defun) (defstruct pprint-defstruct) (deftype pprint-defun) (defun pprint-defun) (defvar pprint-block) (destructuring-bind pprint-destructuring-bind) (do pprint-do) (do* pprint-do) (do-all-symbols pprint-dolist) (do-external-symbols pprint-dolist) (do-symbols pprint-dolist) (dolist pprint-dolist) (dotimes pprint-dolist) (ecase pprint-case) (etypecase pprint-typecase) (handler-bind pprint-handler-bind) (handler-case pprint-handler-bind) ;; Loop is handled by pprint-loop.lisp #+nil(loop pprint-loop) (multiple-value-bind pprint-multiple-value-bind) (multiple-value-setq pprint-block) (pprint-logical-block pprint-block) (print-unreadable-object pprint-with-like) (prog pprint-prog) (prog* pprint-prog) (prog1 pprint-block) (prog2 pprint-progv) (psetf pprint-setq) (psetq pprint-setq) #+nil (restart-bind ...) (restart-case pprint-restart-case) (setf pprint-setq) (step pprint-progn) (time pprint-progn) (typecase pprint-typecase) (unless pprint-when) (when pprint-when) (with-compilation-unit pprint-with-like) (with-condition-restarts pprint-with-like) (with-hash-table-iterator pprint-with-like) (with-input-from-string pprint-with-like) (with-open-file pprint-with-like) (with-open-stream pprint-with-like) (with-output-to-string pprint-with-like) (with-package-iterator pprint-with-like) (with-simple-restart pprint-with-like) (with-standard-io-syntax pprint-progn) ;; CLOS things (defclass pprint-defclass) (defmethod pprint-defmethod) (defgeneric pprint-defgeneric) (with-slots pprint-multiple-value-bind) (with-accessors pprint-multiple-value-bind) ;; Other things in CMUCL that we ought to try to print out nicely. (ext:collect pprint-with-like) (ansi-loop::with-loop-list-collection-head pprint-with-like) (ansi-loop::loop-body pprint-progn) (lisp::descend-into pprint-with-like) (vm::pseudo-atomic pprint-with-like) (new-assem:without-scheduling pprint-with-like) (vm::with-fixed-allocation pprint-with-like) (kernel::number-dispatch pprint-with-like) (stream::with-stream-class pprint-with-like) (lisp::with-array-data pprint-with-like))) (defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) (*building-initial-table* t)) (handler-bind ((standard-pprint-dispatch-table-modified-error (lambda (c) (declare (ignore c)) ;; Of course, we want to be able to modify the standard ;; pprint dispatch table here! (invoke-restart 'kernel::continue)))) ;; Printers for regular types. (set-pprint-dispatch 'array #'pprint-array) (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) #'pprint-function-call -1) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; Cons cells with interesting things for the car. (dolist (magic-form *magic-forms*) (set-pprint-dispatch `(cons (eql ,(first magic-form))) (symbol-function (second magic-form)))) ;; Other pretty-print init forms. (lisp::backq-pp-init) (loop-pp-init))) (setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) (setf *pretty-printer* #'output-pretty-object) (setf *print-pretty* t)) cmucl-21a/src/code/pred.lisp000066400000000000000000000350631260377556400161140ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/pred.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Predicate functions for CMU Common Lisp. ;;; ;;; Written by William Lott. ;;; (in-package "KERNEL") (intl:textdomain "cmucl") (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p %typep class-cell-typep)) #+double-double (export '(double-double-float-p)) (in-package "SYSTEM") (export '(system-area-pointer system-area-pointer-p)) (in-package "LISP") (export '(typep null symbolp atom consp listp numberp integerp rationalp floatp complexp characterp stringp bit-vector-p vectorp simple-vector-p simple-string-p simple-bit-vector-p arrayp functionp compiled-function-p eq eql equal equalp not type-of upgraded-array-element-type realp ;; Names of types... array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum float function integer keyword list long-float nil null number ratio rational real sequence short-float signed-byte simple-array simple-bit-vector simple-string simple-vector single-float standard-char base-char string symbol t unsigned-byte vector satisfies)) ;;;; Primitive predicates. These must be supported by the compiler. (eval-when (compile eval) (defparameter primitive-predicates '(array-header-p arrayp atom base-char-p bignump bit-vector-p characterp code-component-p consp compiled-function-p complexp complex-double-float-p complex-float-p #+long-float complex-long-float-p #+double-double complex-double-double-float-p complex-rational-p complex-single-float-p #+double-double double-double-float-p double-float-p fdefn-p fixnump floatp functionp integerp listp long-float-p lra-p not null numberp rationalp ratiop realp scavenger-hook-p short-float-p simple-array-p simple-bit-vector-p simple-string-p simple-vector-p single-float-p stringp %instancep symbolp system-area-pointer-p weak-pointer-p vectorp unsigned-byte-32-p signed-byte-32-p simple-array-unsigned-byte-2-p simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p simple-array-signed-byte-8-p simple-array-signed-byte-16-p simple-array-signed-byte-30-p simple-array-signed-byte-32-p simple-array-single-float-p simple-array-double-float-p #+long-float simple-array-long-float-p #+double-double simple-array-double-double-float-p simple-array-complex-single-float-p simple-array-complex-double-float-p #+long-float simple-array-complex-long-float-p #+double-double simple-array-complex-double-double-float-p ))) (macrolet ((frob () `(progn ,@(mapcar #'(lambda (pred) `(defun ,pred (object) ,(format nil "Return T if OBJECT is a~:[~;n~] ~(~A~) ~ and NIL otherwise." (find (schar (string pred) 0) "AEIOUaeiou") (string pred)) (,pred object))) primitive-predicates)))) (frob)) ;;;; TYPE-OF -- public. ;;; ;;; Return the specifier for the type of object. This is not simply ;;; (type-specifier (ctype-of object)) because ctype-of has different goals ;;; than type-of. In particular, speed is more important than precision, and ;;; it is not permitted to return member types. ;;; (defun type-of (object) "Return the type of OBJECT." (typecase object ((or array complex) (type-specifier (ctype-of object))) (integer `(integer ,object ,object)) ((member t) 'boolean) (keyword 'keyword) (standard-char 'standard-char) (t (let* ((class (layout-class (layout-of object))) (name (%class-name class))) (if (%instancep object) (if (eq name 'alien-internals:alien-value) `(alien:alien ,(alien-internals:unparse-alien-type (alien-internals:alien-value-type object))) (let ((proper-name (class-proper-name class))) (if (kernel::class-p proper-name) (%class-pcl-class proper-name) proper-name))) name))))) ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public ;;; (defun upgraded-array-element-type (spec &optional environment) "Return the element type that will actually be used to implement an array with the specifier :ELEMENT-TYPE Spec." ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments. (declare (ignore environment)) (type-specifier (array-type-specialized-element-type (specifier-type `(array ,spec))))) ;;;; SUBTYPEP -- public. ;;; ;;; Just parse the type specifiers and call csubtype. ;;; (defun subtypep (type1 type2 &optional environment) "Return two values indicating the relationship between type1 and type2: T and T: type1 definitely is a subtype of type2. NIL and T: type1 definitely is not a subtype of type2. NIL and NIL: who knows?" (declare (ignore environment)) (csubtypep (specifier-type type1) (specifier-type type2))) ;;;; TYPEP: (declaim (start-block typep %typep class-cell-typep)) ;;; TYPEP -- public. ;;; ;;; Just call %typep ;;; (defun typep (object type &optional environment) "Return T iff OBJECT is of type TYPE." (declare (ignore environment)) (%typep object type)) ;;; %TYPEP -- internal. ;;; ;;; The actual typep engine. The compiler only generates calls to this ;;; function when it can't figure out anything more intelligent to do. ;;; (defun %typep (object specifier) (%%typep object (if (ctype-p specifier) specifier (specifier-type specifier)))) ;;; (defun %%typep (object type) (declare (type ctype type)) (etypecase type (named-type (ecase (named-type-name type) ((* t) t) ((nil) nil))) (numeric-type (and (numberp object) (let ((num (if (complexp object) (realpart object) object))) (ecase (numeric-type-class type) (integer (integerp num)) (rational (rationalp num)) (float (ecase (numeric-type-format type) (short-float (typep num 'short-float)) (single-float (typep num 'single-float)) (double-float (typep num 'double-float)) (long-float (typep num 'long-float)) (double-double-float (typep num 'double-double-float)) ((nil) (floatp num)))) ((nil) t))) (flet ((bound-test (val) (let ((low (numeric-type-low type)) (high (numeric-type-high type))) (and (cond ((null low) t) ((listp low) (> val (car low))) (t (>= val low))) (cond ((null high) t) ((listp high) (< val (car high))) (t (<= val high))))))) (ecase (numeric-type-complexp type) ((nil) t) (:complex (and (complexp object) (bound-test (realpart object)) (bound-test (imagpart object)))) (:real (and (not (complexp object)) (bound-test object))))))) (array-type (and (arrayp object) (ecase (array-type-complexp type) ((t) (not (typep object 'simple-array))) ((nil) (typep object 'simple-array)) ((* :maybe) t)) (or (eq (array-type-dimensions type) '*) (do ((want (array-type-dimensions type) (cdr want)) (got (array-dimensions object) (cdr got))) ((and (null want) (null got)) t) (unless (and want got (or (eq (car want) '*) (= (car want) (car got)))) (return nil)))) (if (unknown-type-p (array-type-element-type type)) ;; better to fail this way than to get bogosities like ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T (error (intl:gettext "~@") (type-specifier type)) t) (or (eq (array-type-element-type type) *wild-type*) (values (type= (array-type-specialized-element-type type) (specifier-type (array-element-type object))))))) (member-type (if (member object (member-type-members type)) t)) (kernel::class (class-typep (layout-of object) type object)) (union-type (some (lambda (type) (%%typep object type)) (union-type-types type))) (intersection-type (every (lambda (type) (%%typep object type)) (intersection-type-types type))) (cons-type (and (consp object) (%%typep (car object) (cons-type-car-type type)) (%%typep (cdr object) (cons-type-cdr-type type)))) (unknown-type ;; Parse it again to make sure it's really undefined. (let ((reparse (specifier-type (unknown-type-specifier type)))) (if (typep reparse 'unknown-type) (error (intl:gettext "Unknown type specifier: ~S") (unknown-type-specifier reparse)) (%%typep object reparse)))) (negation-type (not (%%typep object (negation-type-type type)))) (hairy-type ;; Now the tricky stuff. (let* ((hairy-spec (hairy-type-specifier type)) (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) (ecase symbol (and (every (lambda (spec) (%%typep object (specifier-type spec))) (rest hairy-spec))) ;; Note: it should be safe to skip OR here, because union ;; types can always be represented as UNION-TYPE in general ;; or other CTYPEs in special cases; we never need to use ;; HAIRY-TYPE for them. (not (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) (error (intl:gettext "Invalid type specifier: ~S") hairy-spec)) (not (%%typep object (specifier-type (cadr hairy-spec))))) (satisfies (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) (error (intl:gettext "Invalid type specifier: ~S") hairy-spec)) (let ((fn (cadr hairy-spec))) (if (funcall (typecase fn (function fn) (symbol (symbol-function fn)) (t (coerce fn 'function))) object) t nil)))))) (alien-type-type (alien-internals:alien-typep object (alien-type-type-alien-type type))) (function-type (error (intl:gettext "Function types are not a legal argument to TYPEP:~% ~S") (type-specifier type))))) ;;; CLASS-CELL-TYPEP -- Interface ;;; ;;; Do type test from a class cell, allowing forward reference and ;;; redefinition. ;;; (defun class-cell-typep (obj-layout cell object) (let ((class (class-cell-class cell))) (unless class (error (intl:gettext "Class has not yet been defined: ~S") (class-cell-name cell))) (class-typep obj-layout class object))) ;;; CLASS-TYPEP -- Internal ;;; ;;; Test whether Obj-Layout is from an instance of Class. ;;; (defun class-typep (obj-layout class object) (declare (optimize speed)) (when (layout-invalid obj-layout) (if (and (typep (kernel::class-of object) 'kernel::standard-class) object) (setq obj-layout (pcl::check-wrapper-validity object)) (error (intl:gettext "TYPEP on obsolete object (was class ~S).") (class-proper-name (layout-class obj-layout))))) (let ((layout (%class-layout class)) (obj-inherits (layout-inherits obj-layout))) (when (layout-invalid layout) (error (intl:gettext "Class is currently invalid: ~S") class)) (or (eq obj-layout layout) (dotimes (i (length obj-inherits) nil) (when (eq (svref obj-inherits i) layout) (return t)))))) (declaim (end-block)) ;;;; Equality predicates. ;;; EQ -- public. ;;; ;;; Real simple, 'cause the compiler takes care of it. ;;; (defun eq (obj1 obj2) "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." (eq obj1 obj2)) ;;; EQUAL -- public. ;;; (defun equal (x y) "Returns T if X and Y are EQL or if they are structured components whose elements are EQUAL. Strings and bit-vectors are EQUAL if they are the same length and have indentical components. Other arrays must be EQ to be EQUAL." (cond ((eql x y) t) ((consp x) (and (consp y) (equal (car x) (car y)) (equal (cdr x) (cdr y)))) ((stringp x) (and (stringp y) (string= x y))) ((pathnamep x) (and (pathnamep y) (pathname= x y))) ((bit-vector-p x) (and (bit-vector-p y) (= (the fixnum (length x)) (the fixnum (length y))) (do ((i 0 (1+ i)) (length (length x))) ((= i length) t) (declare (fixnum i)) (or (= (the fixnum (bit x i)) (the fixnum (bit y i))) (return nil))))) (t nil))) ;;; EQUALP -- public. ;;; (defun equalp (x y) "Just like EQUAL, but more liberal in several respects. Numbers may be of different types, as long as the values are identical after coercion. Characters may differ in alphabetic case. Vectors and arrays must have identical dimensions and EQUALP elements, but may differ in their type restriction." (cond ((eq x y) t) ((characterp x) (and (characterp y) (char-equal x y))) ((numberp x) (and (numberp y) (= x y))) ((consp x) (and (consp y) (equalp (car x) (car y)) (equalp (cdr x) (cdr y)))) ((pathnamep x) (and (pathnamep y) (pathname= x y))) ((hash-table-p x) (and (hash-table-p y) (eql (hash-table-count x) (hash-table-count y)) (eql (hash-table-test x) (hash-table-test y)) (with-hash-table-iterator (next x) (loop (multiple-value-bind (more x-key x-value) (next) (cond (more (multiple-value-bind (y-value foundp) (gethash x-key y) (unless (and foundp (equalp x-value y-value)) (return nil)))) (t (return t)))))))) ((%instancep x) (let* ((layout-x (%instance-layout x)) (len (layout-length layout-x))) (and (%instancep y) (eq layout-x (%instance-layout y)) (structure-class-p (layout-class layout-x)) (do ((i 1 (1+ i))) ((= i len) t) (declare (fixnum i)) (let ((x-el (%instance-ref x i)) (y-el (%instance-ref y i))) (unless (or (eq x-el y-el) (equalp x-el y-el)) (return nil))))))) ((vectorp x) (let ((length (length x))) (and (vectorp y) (= length (length y)) (dotimes (i length t) (let ((x-el (aref x i)) (y-el (aref y i))) (unless (or (eq x-el y-el) (equalp x-el y-el)) (return nil))))))) ((arrayp x) (and (arrayp y) (= (array-rank x) (array-rank y)) (dotimes (axis (array-rank x) t) (unless (= (array-dimension x axis) (array-dimension y axis)) (return nil))) (dotimes (index (array-total-size x) t) (let ((x-el (row-major-aref x index)) (y-el (row-major-aref y index))) (unless (or (eq x-el y-el) (equalp x-el y-el)) (return nil)))))) (t nil))) cmucl-21a/src/code/print.lisp000066400000000000000000002275511260377556400163230ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/print.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; CMU Common Lisp printer. ;;; ;;; Written by Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey. ;;; Modified by various CMU Common Lisp maintainers. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(*print-readably* *print-escape* *print-pretty* *print-circle* *print-base* *print-radix* *print-case* *print-gensym* *print-level* *print-length* *print-array* *print-lines* *print-right-margin* *print-miser-width* *print-pprint-dispatch* with-standard-io-syntax write prin1 print princ pprint write-to-string prin1-to-string princ-to-string print-unreadable-object print-not-readable print-not-readable-object)) (in-package "KERNEL") (export '(*current-level* *pretty-printer* output-object output-ugly-object check-for-circularity handle-circularity descend-into punt-if-too-long output-symbol-name)) (in-package "LISP") ;;;; Exported printer control variables. (defvar *print-readably* nil _N"If true, all objects will printed readably. If readably printing is impossible, an error will be signalled. This overrides the value of *PRINT-ESCAPE*.") (defvar *print-escape* T _N"Flag which indicates that slashification is on. See the manual") (defvar *print-pretty* nil _N"Flag which indicates that pretty printing is to be used") (defvar *print-base* 10. _N"The output base for integers and rationals.") (defvar *print-radix* nil _N"This flag requests to verify base when printing rationals.") (defvar *print-level* nil _N"How many levels deep to print. Unlimited if null.") (defvar *print-length* nil _N"How many elements to print on each level. Unlimited if null.") (defvar *print-circle* nil _N"Whether to worry about circular list structures. See the manual.") (defvar *print-case* :upcase _N"What kind of case the printer should use by default") (defvar *print-array* t _N"Whether the array should print it's guts out") (defvar *print-gensym* t _N"If true, symbols with no home package are printed with a #: prefix. If false, no prefix is printed.") (defvar *print-lines* nil _N"The maximum number of lines to print. If NIL, unlimited.") (defvar *print-right-margin* nil _N"The position of the right margin in ems. If NIL, try to determine this from the stream in use.") (defvar *print-miser-width* nil _N"If the remaining space between the current column and the right margin is less than this, then print using ``miser-style'' output. Miser style conditional newlines are turned on, and all indentations are turned off. If NIL, never use miser mode.") (defvar *print-pprint-dispatch* nil _N"The pprint-dispatch-table that controls how to pretty print objects. See COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.") (defmacro with-standard-io-syntax (&body body) _N"Bind the reader and printer control variables to values that enable READ to reliably read the results of PRINT. These values are: *PACKAGE* The COMMON-LISP-USER package *PRINT-ARRAY* T *PRINT-BASE* 10 *PRINT-CASE* :UPCASE *PRINT-CIRCLE* NIL *PRINT-ESCAPE* T *PRINT-GENSYM* T *PRINT-LENGTH* NIL *PRINT-LEVEL* NIL *PRINT-LINES* NIL *PRINT-MISER-WIDTH* NIL *PRINT-PPRINT-DISPATCH* The standard pprint dispatch table *PRINT-PRETTY* NIL *PRINT-RADIX* NIL *PRINT-READABLY* T *PRINT-RIGHT-MARGIN* NIL *READ-BASE* 10 *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT *READ-EVAL* T *READ-SUPPRESS* NIL *READTABLE* the standard readtable." `(%with-standard-io-syntax #'(lambda () ,@body))) (defun %with-standard-io-syntax (function) (let ((*package* (find-package "CL-USER")) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) (*print-pprint-dispatch* pp::*initial-pprint-dispatch*) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) (*print-right-margin* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) (*readtable* std-lisp-readtable)) (funcall function))) ;;;; Routines to print objects. (defun write (object &key ((:stream stream) *standard-output*) ((:escape *print-escape*) *print-escape*) ((:radix *print-radix*) *print-radix*) ((:base *print-base*) *print-base*) ((:circle *print-circle*) *print-circle*) ((:pretty *print-pretty*) *print-pretty*) ((:level *print-level*) *print-level*) ((:length *print-length*) *print-length*) ((:case *print-case*) *print-case*) ((:array *print-array*) *print-array*) ((:gensym *print-gensym*) *print-gensym*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) _N"Outputs OBJECT to the specified stream, defaulting to *standard-output*" (output-object object (out-synonym-of stream)) object) (defun prin1 (object &optional stream) _N"Outputs a mostly READable printed representation of OBJECT on the specified stream." (let ((*print-escape* T)) (output-object object (out-synonym-of stream))) object) (defun princ (object &optional stream) _N"Outputs an asthetic but not READable printed representation of OBJECT on the specified stream." (let ((*print-escape* NIL) (*print-readably* NIL)) (output-object object (out-synonym-of stream))) object) (defun print (object &optional stream) _N"Outputs a terpri, the mostly READable printed represenation of OBJECT, and space to the stream." (let ((stream (out-synonym-of stream))) (terpri stream) (prin1 object stream) (write-char #\space stream) object)) (defun pprint (object &optional stream) _N"Prettily outputs the Object preceded by a newline." (let ((*print-pretty* t) (*print-escape* t) (stream (out-synonym-of stream))) (terpri stream) (output-object object stream)) (values)) (defun write-to-string (object &key ((:escape *print-escape*) *print-escape*) ((:radix *print-radix*) *print-radix*) ((:base *print-base*) *print-base*) ((:circle *print-circle*) *print-circle*) ((:pretty *print-pretty*) *print-pretty*) ((:level *print-level*) *print-level*) ((:length *print-length*) *print-length*) ((:case *print-case*) *print-case*) ((:array *print-array*) *print-array*) ((:gensym *print-gensym*) *print-gensym*) ((:readably *print-readably*) *print-readably*) ((:right-margin *print-right-margin*) *print-right-margin*) ((:miser-width *print-miser-width*) *print-miser-width*) ((:lines *print-lines*) *print-lines*) ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) _N"Returns the printed representation of OBJECT as a string." (stringify-object object)) (defun prin1-to-string (object) _N"Returns the printed representation of OBJECT as a string with slashification on." (stringify-object object t)) (defun princ-to-string (object) _N"Returns the printed representation of OBJECT as a string with slashification off and readability off." (stringify-object object nil nil)) ;;; STRINGIFY-OBJECT -- Internal. ;;; ;;; This produces the printed representation of an object as a string. The ;;; few ...-TO-STRING functions above call this. ;;; (defvar *string-output-streams* ()) ;;; (defun stringify-object (object &optional (*print-escape* *print-escape*) (*print-readably* *print-readably*)) (let ((stream (if *string-output-streams* (pop *string-output-streams*) (make-string-output-stream)))) (setup-printer-state) (output-object object stream) (prog1 (get-output-stream-string stream) (push stream *string-output-streams*)))) ;;;; PRINT-UNREADABLE-OBJECT macro (defmacro print-unreadable-object ((object stream &key type identity) &body body) `(%print-unreadable-object ,object ,stream ,type ,identity ,(if body `#'(lambda () ,@body) nil))) (define-condition print-not-readable (error) ((object :reader print-not-readable-object :initarg :object)) (:report (lambda (condition stream) (let ((obj (print-not-readable-object condition)) (*print-array* nil)) (format stream (intl:gettext "~S cannot be printed readably.") obj))))) ;;; Guts of print-unreadable-object. ;;; ;;; When *print-pretty* and the stream is a pretty-stream, format the object ;;; within a logical block - pprint-logical-block does not rebind the stream ;;; when it is already a pretty stream so output from the body will go to the ;;; same stream. ;;; (defun %print-unreadable-object (object stream type identity body) (when *print-readably* (error 'print-not-readable :object object)) (flet ((print-description () (when type (write (type-of object) :stream stream :circle nil :level nil :length nil) (when (or body identity) (write-char #\space stream) (pprint-newline :fill stream))) (when body (funcall body)) (when identity (when body (write-char #\space stream) (pprint-newline :fill stream)) (write-char #\{ stream) (write (get-lisp-obj-address object) :stream stream :radix nil :base 16) (write-char #\} stream)))) (cond ((and (pp:pretty-stream-p stream) *print-pretty*) (pprint-logical-block (stream nil :prefix "#<" :suffix ">") (print-description))) ((and *print-level* (>= *current-level* *print-level*)) (write-char #\# stream)) (t (write-string "#<" stream) (print-description) (write-char #\> stream)))) nil) ;;;; WHITESPACE-CHAR-P ;;; This is used in other files, but is defined in this one for some reason. (defun whitespace-char-p (char) "Determines whether or not the character is considered whitespace." (or (char= char #\space) (char= char #\tab) (char= char #\return) (char= char #\linefeed))) ;;;; Circularity detection stuff. ;;; *CIRCULARITY-HASH-TABLE* -- internal. ;;; ;;; When *print-circle* is T, this gets bound to a hash table that (eventually) ;;; ends up with entries for every object printed. When we are initially ;;; looking for circularities, we enter a T when we find an object for the ;;; first time, and a 0 when we encounter an object a second time around. ;;; When we are actually printing, the 0 entries get changed to the actual ;;; marker value when they are first printed. ;;; (defvar *circularity-hash-table* nil) ;;; *CIRCULARITY-COUNTER* -- internal. ;;; ;;; When NIL, we are just looking for circularities. After we have found them ;;; all, this gets bound to 0. Then whenever we need a new marker, it is ;;; incremented. ;;; (defvar *circularity-counter* nil) ;;; CHECK-FOR-CIRCULARITY -- interface. ;;; (defun check-for-circularity (object &optional assign (mode t)) "Check to see if OBJECT is a circular reference, and return something non-NIL if it is. If ASSIGN is T, then the number to use in the #n= and #n# noise is assigned at this time. Note: CHECK-FOR-CIRCULARITY must be called *EXACTLY* once with ASSIGN T, or the circularity detection noise will get confused about when to use #n= and when to use #n#. If this returns non-NIL when ASSIGN is T, then you must call HANDLE-CIRCULARITY on it." (cond ((null *print-circle*) ;; Don't bother, nobody cares. nil) ((null *circularity-hash-table*) (values nil :initiate)) ((null *circularity-counter*) (ecase (gethash object *circularity-hash-table*) ((nil) ;; First encounter. (setf (gethash object *circularity-hash-table*) mode) ;; We need to keep looking. nil) ((:logical-block) (setf (gethash object *circularity-hash-table*) :logical-block-circular) t) ((t) (cond ((eq mode :logical-block) ;; We've seen the object before in output-object, and now ;; a second time in a PPRINT-LOGICAL-BLOCK (for example ;; via pprint-dispatch). Don't mark it as circular yet. (setf (gethash object *circularity-hash-table*) :logical-block) nil) (t ;; Second encounter. (setf (gethash object *circularity-hash-table*) 0) ;; It's a circular reference. t))) ((0 :logical-block-circular) ;; It's a circular reference. t))) (t (let ((value (gethash object *circularity-hash-table*))) (case value ((nil t :logical-block) ;; If NIL, we found an object that wasn't there the ;; first time around. If T or :LOGICAL-BLOCK, exactly ;; one occurance of this object appears. Either way, ;; just print the thing without any special processing. ;; Note: you might argue that finding a new object means ;; that something is broken, but this can happen. If ;; someone uses the ~@<...~:> format directive, it ;; conses a new list each time though format (i.e. the ;; &REST list), so we will have different cdrs. nil) (:logical-block-circular ;; A circular reference to something that will be printed ;; as a logical block. Wait until we're called from ;; PPRINT-LOGICAL-BLOCK with ASSIGN true before assigning the ;; number. ;; ;; If mode is :LOGICAL-BLOCK and assign is false, return true ;; to indicate that this object is circular, but don't assign ;; it a number yet. This is neccessary for cases like ;; #1=(#2=(#2# . #3=(#1# . #3#))))). (cond ((and (not assign) (eq mode :logical-block)) t) ((and assign (eq mode :logical-block)) (let ((value (incf *circularity-counter*))) ;; first occurrence of this object: Set the counter. (setf (gethash object *circularity-hash-table*) value) value)) (t nil))) (0 (if assign (let ((value (incf *circularity-counter*))) ;; First occurance of this object. Set the counter. (setf (gethash object *circularity-hash-table*) value) value) t)) (t ;; Second or later occurance. (- value))))))) ;;; HANDLE-CIRCULARITY -- interface. ;;; (defun handle-circularity (marker stream) "Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then you should go ahead and print the object. If it returns NIL, then you should blow it off." (case marker (:initiate ;; Someone forgot to initiate circularity detection. (let ((*print-circle* nil)) (error (intl:gettext "Attempt to use CHECK-FOR-CIRCULARITY when circularity ~ checking has not been initiated.")))) ((t :logical-block) ;; It's a second (or later) reference to the object while we are ;; just looking. So don't bother groveling it again. nil) (t (write-char #\# stream) (let ((*print-base* 10) (*print-radix* nil)) (cond ((minusp marker) (output-integer (- marker) stream) (write-char #\# stream) nil) (t (output-integer marker stream) (write-char #\= stream) t)))))) (defmacro with-circularity-detection ((object stream) &body body) (let ((marker (gensym "WITH-CIRCULARITY-DETECTION-")) (body-name (gensym "WITH-CIRCULARITY-DETECTION-BODY-"))) `(labels ((,body-name () ,@body)) (cond ((not *print-circle*) (,body-name)) (*circularity-hash-table* (let ((,marker (check-for-circularity ,object t :logical-block))) (if ,marker (when (handle-circularity ,marker ,stream) (,body-name)) (,body-name)))) (t (let ((*circularity-hash-table* (make-hash-table :test 'eq))) (output-object ,object (make-broadcast-stream)) (let ((*circularity-counter* 0)) (let ((,marker (check-for-circularity ,object t :logical-block))) (when ,marker (handle-circularity ,marker ,stream))) (,body-name)))))))) ;;;; Level and Length abbreviations. ;;; *CURRENT-LEVEL* -- interface. ;;; (defvar *current-level* 0 "The current level we are printing at, to be compared against *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to depth abbreviation.") ;;; DESCEND-INTO -- interface. ;;; (defmacro descend-into ((stream) &body body) "Automatically handle *print-level* abbreviation. If we are too deep, then a # is printed to STREAM and BODY is ignored." (let ((flet-name (gensym))) `(flet ((,flet-name () ,@body)) (cond ((and (null *print-readably*) *print-level* (>= *current-level* *print-level*)) (write-char #\# ,stream)) (t (let ((*current-level* (1+ *current-level*))) (,flet-name))))))) ;;; PUNT-IF-TOO-LONG -- interface. ;;; (defmacro punt-if-too-long (index stream) "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY* is NIL) by outputting \"...\" and returning from the block named NIL." `(when (and (not *print-readably*) *print-length* (>= ,index *print-length*)) (write-string "..." ,stream) (return))) ;;;; OUTPUT-OBJECT -- the main entry point. ;;; *PRETTY-PRINTER* -- public. ;;; (defvar *pretty-printer* nil "The current pretty printer. Should be either a function that takes two arguments (the object and the stream) or NIL to indicate that there is no pretty printer installed.") ;;; OUTPUT-OBJECT -- interface. ;;; (defun output-object (object stream) "Output OBJECT to STREAM observing all printer control variables." (labels ((print-it (stream) (if *print-pretty* (if *pretty-printer* (funcall *pretty-printer* object stream) (let ((*print-pretty* nil)) (output-ugly-object object stream))) (output-ugly-object object stream))) (check-it (stream) (multiple-value-bind (marker initiate) (check-for-circularity object t) (if (eq initiate :initiate) (let ((*circularity-hash-table* (make-hash-table :test 'eq))) (check-it (make-broadcast-stream)) (let ((*circularity-counter* 0)) (check-it stream))) (if marker (when (handle-circularity marker stream) (print-it stream)) (print-it stream)))))) (cond ((or (not *print-circle*) (numberp object) (characterp object) (and (symbolp object) (symbol-package object) t)) ;; If it a number, character, or interned symbol, we do not want ;; to check for circularity/sharing. (print-it stream)) ((or *circularity-hash-table* (consp object) (%instancep object) (typep object '(array t *)) (typep object 'weak-pointer)) ;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, ;; then if it is a cons, a instance, an array of element ;; type t, or a weak-pointer it might contain a circular ;; reference to itself or multiple shared references. (check-it stream)) (t (print-it stream))))) ;;; OUTPUT-UGLY-OBJECT -- interface. ;;; (defun output-ugly-object (object stream) "Output OBJECT to STREAM observing all printer control variables except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, then the pretty printer will be used for any components of OBJECT, just not for OBJECT itself." (typecase object (fixnum (output-integer object stream)) (list (if (null object) (output-symbol object stream) (output-list object stream))) (instance (output-instance object stream)) (function (if (funcallable-instance-p object) (output-instance object stream) (output-function object stream))) (symbol (output-symbol object stream)) (number (etypecase object (integer (output-integer object stream)) (float (output-float object stream)) (ratio (output-ratio object stream)) (complex (output-complex object stream)))) (character (output-character object stream)) (vector (output-vector object stream)) (array (output-array object stream)) (system-area-pointer (output-sap object stream)) (weak-pointer (output-weak-pointer object stream)) (lra (output-lra object stream)) (code-component (output-code-component object stream)) (fdefn (output-fdefn object stream)) #+gencgc (scavenger-hook (output-scavhook object stream)) (t (output-random object stream)))) ;;;; Symbols. ;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last time the ;;; printer was called. ;;; (defvar *previous-case* nil) (defvar *previous-readtable-case* nil) ;;; This variable contains the current definition of one of three symbol ;;; printers. SETUP-PRINTER-STATE sets this variable. ;;; (defvar *internal-symbol-output-function* nil) ;;; SETUP-PRINTER-STATE -- Internal. ;;; ;;; This function sets the internal global symbol ;;; *internal-symbol-output-function* to the right function depending on the ;;; value of *print-case*. See the manual for details. The print buffer ;;; stream is also reset. ;;; (defun setup-printer-state () (unless (and (eq *print-case* *previous-case*) (eq (readtable-case *readtable*) *previous-readtable-case*)) (setq *previous-case* *print-case*) (setq *previous-readtable-case* (readtable-case *readtable*)) (unless (member *print-case* '(:upcase :downcase :capitalize)) (setq *print-case* :upcase) (error (intl:gettext "Invalid *PRINT-CASE* value: ~S") *previous-case*)) (unless (member *previous-readtable-case* '(:upcase :downcase :invert :preserve)) (setf (readtable-case *readtable*) :upcase) (error (intl:gettext "Invalid READTABLE-CASE value: ~S") *previous-readtable-case*)) (setq *internal-symbol-output-function* (case *previous-readtable-case* (:upcase (case *print-case* (:upcase #'output-preserve-symbol) (:downcase #'output-lowercase-symbol) (:capitalize #'output-capitalize-symbol))) (:downcase (case *print-case* (:upcase #'output-uppercase-symbol) (:downcase #'output-preserve-symbol) (:capitalize #'output-capitalize-symbol))) (:preserve #'output-preserve-symbol) (:invert #'output-invert-symbol))))) ;;; OUTPUT-QUOTED-SYMBOL-NAME -- Internal ;;; ;;; Out Pname (a symbol-name or package-name) surrounded with |'s, and with ;;; any embedded |'s or \'s escaped. ;;; (defun output-quoted-symbol-name (pname stream) (write-char #\| stream) (dotimes (index (length pname)) (let ((char (schar pname index))) (when (or (char= char #\\) (char= char #\|)) (write-char #\\ stream)) (write-char char stream))) (write-char #\| stream)) (defun output-symbol (object stream) (if (or *print-escape* *print-readably*) (let ((package (symbol-package object)) (name (symbol-name object))) (cond ;; If the symbol is in the keyword package, output a colon. ((eq package *keyword-package*) (write-char #\: stream)) ;; If the symbol's home package is the current one, then a ;; prefix is never necessary. ((eq package *package*)) ;; Uninterned symbols print with a leading #:. ((null package) (when (or *print-gensym* *print-readably*) (write-string "#:" stream))) (t (multiple-value-bind (symbol accessible) (find-symbol name *package*) ;; If we can find the symbol by looking it up, it need not be ;; qualified. This can happen if the symbol has been inherited ;; from a package other than its home package. (unless (and accessible (eq symbol object)) (output-symbol-name (package-name package) stream) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) (if externalp (write-char #\: stream) (write-string "::" stream))))))) (output-symbol-name name stream)) (output-symbol-name (symbol-name object) stream nil))) ;;; OUTPUT-SYMBOL-NAME -- internal interface. ;;; ;;; Output the string NAME as if it were a symbol name. In other words, ;;; diddle it's case according to *print-case* and readtable-case. ;;; (defun output-symbol-name (name stream &optional (maybe-quote t)) (declare (type simple-base-string name)) (let ((*readtable* (if *print-readably* std-lisp-readtable *readtable*))) (setup-printer-state) (if (and maybe-quote (symbol-quotep name)) (output-quoted-symbol-name name stream) (funcall *internal-symbol-output-function* name stream)))) ;;;; Escaping symbols: ;;; When we print symbols we have to figure out if they need to be ;;; printed with escape characters. This isn't a whole lot easier than ;;; reading symbols in the first place. ;;; ;;; For each character, the value of the corresponding element is a fixnum with ;;; bits set corresponding to attributes that the character has. At characters ;;; have at least one bit set, so we can search for any character with a ;;; positive test. ;;; (defvar character-attributes (make-array char-code-limit :element-type '(unsigned-byte 16) :initial-element 0)) ;;; (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit)) character-attributes)) (eval-when (compile load eval) ;;; Constants which are a bit-mask for each interesting character attribute. ;;; (defconstant other-attribute (ash 1 0)) ; Anything else legal. (defconstant number-attribute (ash 1 1)) ; A numeric digit. (defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter. (defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter. (defconstant sign-attribute (ash 1 4)) ; +- (defconstant extension-attribute (ash 1 5)) ; ^_ (defconstant dot-attribute (ash 1 6)) ; . (defconstant slash-attribute (ash 1 7)) ; / (defconstant funny-attribute (ash 1 8)) ; Anything illegal. (defconstant othercase-attribute (ash 1 9)) ; A letter that has no case. ;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that ;;; don't need to be escaped (according to READTABLE-CASE.) ;;; (defconstant attribute-names `((number . number-attribute) (lowercase . lowercase-attribute) (uppercase . uppercase-attribute) (letter . letter-attribute) (sign . sign-attribute) (extension . extension-attribute) (dot . dot-attribute) (slash . slash-attribute) (other . other-attribute) (funny . funny-attribute) #+unicode (othercase . othercase-attribute))) ); Eval-When (compile load eval) (flet ((set-bit (char bit) (let ((code (char-code char))) (setf (aref character-attributes code) (logior bit (aref character-attributes code)))))) (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} #\? #\< #\>)) (set-bit char other-attribute)) (dotimes (i 10) (set-bit (digit-char i) number-attribute)) (do ((code (char-code #\A) (1+ code)) (end (char-code #\Z))) ((> code end)) (declare (fixnum code end)) (set-bit (code-char code) uppercase-attribute) (set-bit (char-downcase (code-char code)) lowercase-attribute)) (set-bit #\- sign-attribute) (set-bit #\+ sign-attribute) (set-bit #\^ extension-attribute) (set-bit #\_ extension-attribute) (set-bit #\. dot-attribute) (set-bit #\/ slash-attribute) ;; We only initialize the things for 8-bit characters here. The ;; full set is initialized later by REINIT-CHAR-ATTRIBUTES, below (dotimes (i 256) (when (zerop (aref character-attributes i)) (setf (aref character-attributes i) funny-attribute)))) ;;; For each character, the value of the corresponding element is the lowest ;;; base in which that character is a digit. ;;; (defvar digit-bases (make-array char-code-limit :element-type '(unsigned-byte 8) :initial-element 36)) ;;; (declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit)) digit-bases)) (dotimes (i 36) (let ((char (digit-char i 36))) (setf (aref digit-bases (char-code char)) i))) ;;; SYMBOL-QUOTEP -- Internal ;;; ;;; A FSM-like thingie that determines whether a symbol is a potential ;;; number or has evil characters in it. ;;; (defun symbol-quotep (name) (declare (simple-string name)) (macrolet ((advance (tag &optional (at-end t)) `(progn (when (= index len) ,(if at-end '(go TEST-SIGN) '(return nil))) (setq current (schar name index) code (char-code current) bits (aref attributes code)) (incf index) (go ,tag))) (test (&rest attributes) `(not (zerop (the fixnum (logand (logior ,@(mapcar #'(lambda (x) (or (cdr (assoc x attribute-names)) (error "Blast!"))) attributes)) bits))))) (digitp () `(< (the fixnum (aref bases code)) base))) (prog ((len (length name)) (attributes character-attributes) (bases digit-bases) (base *print-base*) (letter-attribute (case (readtable-case *readtable*) (:upcase (logior uppercase-attribute #+unicode othercase-attribute)) (:downcase (logior lowercase-attribute #+unicode othercase-attribute)) (t (logior lowercase-attribute uppercase-attribute)))) (index 0) (bits 0) (code 0) current) (declare (fixnum len base index bits code)) (advance START t) TEST-SIGN ; At end, see if it is a sign... (return (not (test sign))) OTHER ; Not potential number, see if funny chars... (let ((mask (logxor (logior lowercase-attribute uppercase-attribute #+unicode othercase-attribute funny-attribute) letter-attribute))) (do ((i (1- index) (1+ i))) ((= i len) (return-from symbol-quotep nil)) (unless (zerop (logand (aref attributes (char-code (schar name i))) mask)) (return-from symbol-quotep t)))) START (when (digitp) (if (test letter) (advance LAST-DIGIT-ALPHA) (advance DIGIT))) (when (test letter number other slash) (advance OTHER nil)) (when (char= current #\.) (advance DOT-FOUND)) (when (test sign extension) (advance START-STUFF nil)) (return t) DOT-FOUND ; Leading dots... (when (test letter) (advance START-DOT-MARKER nil)) (when (digitp) (advance DOT-DIGIT)) (when (test number other) (advance OTHER nil)) (when (test extension slash sign) (advance START-DOT-STUFF nil)) (when (char= current #\.) (advance DOT-FOUND)) (return t) START-STUFF ; Leading stuff before any dot or digit. (when (digitp) (if (test letter) (advance LAST-DIGIT-ALPHA) (advance DIGIT))) (when (test number other) (advance OTHER nil)) (when (test letter) (advance START-MARKER nil)) (when (char= current #\.) (advance START-DOT-STUFF nil)) (when (test sign extension slash) (advance START-STUFF nil)) (return t) START-MARKER ; Number marker in leading stuff... (when (test letter) (advance OTHER nil)) (go START-STUFF) START-DOT-STUFF ; Leading stuff containing dot w/o digit... (when (test letter) (advance START-DOT-STUFF nil)) (when (digitp) (advance DOT-DIGIT)) (when (test sign extension dot slash) (advance START-DOT-STUFF nil)) (when (test number other) (advance OTHER nil)) (return t) START-DOT-MARKER ; Number marker in leading stuff w/ dot.. ;; Leading stuff containing dot w/o digit followed by letter... (when (test letter) (advance OTHER nil)) (go START-DOT-STUFF) DOT-DIGIT ; In a thing with dots... (when (test letter) (advance DOT-MARKER)) (when (digitp) (advance DOT-DIGIT)) (when (test number other) (advance OTHER nil)) (when (test sign extension dot slash) (advance DOT-DIGIT)) (return t) DOT-MARKER ; Number maker in number with dot... (when (test letter) (advance OTHER nil)) (go DOT-DIGIT) LAST-DIGIT-ALPHA ; Previous char is a letter digit... (when (or (digitp) (test sign slash)) (advance ALPHA-DIGIT)) (when (test letter number other dot) (advance OTHER nil)) (return t) ALPHA-DIGIT ; Seen a digit which is a letter... (when (or (digitp) (test sign slash)) (if (test letter) (advance LAST-DIGIT-ALPHA) (advance ALPHA-DIGIT))) (when (test letter) (advance ALPHA-MARKER)) (when (test number other dot) (advance OTHER nil)) (return t) ALPHA-MARKER ; Number marker in number with alpha digit... (when (test letter) (advance OTHER nil)) (go ALPHA-DIGIT) DIGIT ; Seen only real numeric digits... (when (digitp) (if (test letter) (advance ALPHA-DIGIT) (advance DIGIT))) (when (test number other) (advance OTHER nil)) (when (test letter) (advance MARKER)) (when (test extension slash sign) (advance DIGIT)) (when (char= current #\.) (advance DOT-DIGIT)) (return t) MARKER ; Number marker in a numeric number... (when (test letter) (advance OTHER nil)) (go DIGIT)))) ;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* ;;; ;;; Case hackery. These functions are stored in ;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of *PRINT-CASE* ;;; and READTABLE-CASE. ;;; ;; Called when: ;; READTABLE-CASE *PRINT-CASE* ;; :UPCASE :UPCASE ;; :DOWNCASE :DOWNCASE ;; :PRESERVE any (defun output-preserve-symbol (pname stream) (declare (simple-string pname)) (write-string pname stream)) ;; Called when: ;; READTABLE-CASE *PRINT-CASE* ;; :UPCASE :DOWNCASE (defun output-lowercase-symbol (pname stream) (declare (simple-string pname)) (dotimes (index (length pname)) (let ((char (schar pname index))) (write-char (char-downcase char) stream)))) ;; Called when: ;; READTABLE-CASE *PRINT-CASE* ;; :DOWNCASE :UPCASE (defun output-uppercase-symbol (pname stream) (declare (simple-string pname)) (dotimes (index (length pname)) (let ((char (schar pname index))) (write-char (char-upcase char) stream)))) ;; Called when: ;; READTABLE-CASE *PRINT-CASE* ;; :UPCASE :CAPITALIZE ;; :DOWNCASE :CAPITALIZE ;; (defun output-capitalize-symbol (pname stream) (declare (simple-string pname)) (let ((prev-not-alpha t) (up (eq (readtable-case *readtable*) :upcase))) (dotimes (i (length pname)) (let ((char (char pname i))) (write-char (if up (if (or prev-not-alpha (lower-case-p char)) char (char-downcase char)) (if prev-not-alpha (char-upcase char) char)) stream) (setq prev-not-alpha (not (alphanumericp char))))))) ;; Called when: ;; READTABLE-CASE *PRINT-CASE* ;; :INVERT any (defun output-invert-symbol (pname stream) (declare (simple-string pname)) (let ((all-upper t) (all-lower t)) (dotimes (i (length pname)) (let ((ch (schar pname i))) (when (both-case-p ch) (if (upper-case-p ch) (setq all-lower nil) (setq all-upper nil))))) (cond (all-upper (output-lowercase-symbol pname stream)) (all-lower (output-uppercase-symbol pname stream)) (t (write-string pname stream))))) #| (defun test1 () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE Input Symbol-name~@ ----------------------------------~%") (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (input '("ZEBRA" "Zebra" "zebra")) (format t "~&:~A~16T~A~24T~A" (string-upcase readtable-case) input (symbol-name (read-from-string input))))))) (defun test2 () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@ --------------------------------------------------------~%") (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (*print-case* '(:upcase :downcase :capitalize)) (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A" (string-upcase readtable-case) (string-upcase *print-case*) (symbol-name symbol) (prin1-to-string symbol) (princ-to-string symbol))))))) |# (defun array-readably-printable-p (array) (and (eq (array-element-type array) t) (let ((zero (position 0 (array-dimensions array))) (number (position 0 (array-dimensions array) :test (complement #'eql) :from-end t))) (or (null zero) (null number) (> zero number))))) ;;;; Recursive objects. (defun output-list (list stream) (descend-into (stream) (write-char #\( stream) (let ((length 0) (list list)) (loop (punt-if-too-long length stream) (output-object (pop list) stream) (unless list (return)) (when (or (atom list) (check-for-circularity list)) (write-string " . " stream) (output-object list stream) (return)) (write-char #\space stream) (incf length))) (write-char #\) stream))) (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) (cond ((or *print-escape* *print-readably*) (write-char #\" stream) (quote-string vector stream) (write-char #\" stream)) (t (write-string vector stream)))) ((not (or *print-array* *print-readably*)) (output-terse-array vector stream)) ((bit-vector-p vector) (write-string "#*" stream) (dotimes (i (length vector)) (ecase (aref vector i) (0 (write-char #\0 stream)) (1 (write-char #\1 stream))))) ((and *print-readably* (not (array-readably-printable-p vector))) (output-array vector stream)) (t (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) (unless (zerop i) (write-char #\space stream)) (punt-if-too-long i stream) (output-object (aref vector i) stream)) (write-string ")" stream))))) ;;; QUOTE-STRING -- Internal. ;;; ;;; This function outputs a string quoting characters sufficiently, so someone ;;; can read it in again. Basically, put a slash in front of an character ;;; satisfying FROB. ;;; (defun quote-string (string stream) (macrolet ((frob (char) ;; Probably should look at readtable, but just do this for now. `(or (char= ,char #\\) (char= ,char #\")))) (with-array-data ((data string) (start) (end (length string))) (do ((index start (1+ index))) ((>= index end)) (let ((char (schar data index))) (when (frob char) (write-char #\\ stream)) (write-char char stream)))))) (defun output-array (array stream) "Outputs the printed representation of any array in either the #< or #A form." (if (or *print-array* *print-readably*) (output-array-guts array stream) (output-terse-array array stream))) ;;; Master function for outputing the #A form of an array ;;; (defun output-array-guts (array stream) (with-array-data ((data array) (start) (end)) (declare (ignore end)) (cond (*print-readably* (write-string "#A(" stream) (output-object (array-element-type array) stream) (write-char #\Space stream) (output-object (array-dimensions array) stream) (write-char #\Space stream) (sub-output-array-guts data (array-dimensions array) stream start) (write-char #\) stream)) (t (write-char #\# stream) (let ((*print-base* 10)) (output-integer (array-rank array) stream)) (write-char #\A stream) (sub-output-array-guts data (array-dimensions array) stream start))))) (defun sub-output-array-guts (array dimensions stream index) (declare (type (simple-array * (*)) array) (fixnum index)) (cond ((null dimensions) (output-object (aref array index) stream)) (t (descend-into (stream) (write-char #\( stream) (let* ((dimension (car dimensions)) (dimensions (cdr dimensions)) (count (reduce #'* dimensions))) (dotimes (i dimension) (unless (zerop i) (write-char #\space stream)) (punt-if-too-long i stream) (sub-output-array-guts array dimensions stream index) (incf index count))) (write-char #\) stream))))) ;;; Used to output the #< form of any array. ;;; (defun output-terse-array (array stream) (let ((*print-level* nil) (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) ;;; Instance Printing. If it's a structure, call the structure printer. ;;; Otherwise, call PCL if it's loaded. If not, print unreadably. (defun output-instance (instance stream) (let ((layout (typecase instance (instance (%instance-ref instance 0)) (funcallable-instance (%funcallable-instance-layout instance))))) (if (typep layout 'layout) (let ((class (layout-class layout))) (cond ((typep class 'slot-class) ; has slot print-function (if (layout-invalid layout) (print-unreadable-object (instance stream :identity t :type t) (write-string _"Obsolete Instance" stream)) (cond (;; non-CLOS :print-function option (slot-class-print-function class) (funcall (slot-class-print-function class) instance stream *current-level*)) ;; When CLOS loaded, use PRINT-OBJECT. ((fboundp 'print-object) (print-object instance stream)) (t (default-structure-print instance stream *current-level*))))) ((fboundp 'print-object) (print-object instance stream)) (t (print-unreadable-object (instance stream :identity t) (write-string _"Unprintable Instance" stream))))) (print-unreadable-object (instance stream :identity t) (write-string _"Unprintable Instance" stream))))) #+ORIGINAL (defun output-instance (instance stream) (let ((layout (typecase instance (instance (%instance-ref instance 0)) (funcallable-instance (%funcallable-instance-layout instance))))) (if (typep layout 'layout) (let ((class (layout-class layout))) (cond ((typep class 'slot-class) (if (layout-invalid layout) (print-unreadable-object (instance stream :identity t :type t) (write-string _"Obsolete Instance" stream)) (funcall (or (slot-class-print-function class) #'default-structure-print) instance stream *current-level*))) ((fboundp 'print-object) (print-object instance stream)) (t (print-unreadable-object (instance stream :identity t) (write-string _"Unprintable Instance" stream))))) (print-unreadable-object (instance stream :identity t) (write-string _"Unprintable Instance" stream))))) ;;;; Integer, ratio, and complex printing. (i.e. everything but floats) (defun output-integer (integer stream) (unless (and (fixnump *print-base*) (< 1 *print-base* 37)) (let ((obase *print-base*)) (setq *print-base* 10.) (error _"~A is not a reasonable value for *Print-Base*." obase))) (when (and (not (= *print-base* 10.)) *print-radix*) ;; First print leading base information, if any. (write-char #\# stream) (write-char (case *print-base* (2. #\b) (8. #\o) (16. #\x) (T (let ((fixbase *print-base*) (*print-base* 10.) (*print-radix* ())) (sub-output-integer fixbase stream)) #\r)) stream)) ;; Then output a minus sign if the number is negative, then output ;; the absolute value of the number. (cond ((bignump integer) (print-bignum integer stream)) ((< integer 0) (write-char #\- stream) (sub-output-integer (- integer) stream)) (t (sub-output-integer integer stream))) ;; Print any trailing base information, if any. (if (and (= *print-base* 10.) *print-radix*) (write-char #\. stream))) (defun sub-output-integer (integer stream) (declare (type (integer 0 #.(- most-negative-fixnum)) integer)) (let ((quotient 0) (remainder 0)) (declare (fixnum quotient remainder)) ;; Recurse until you have all the digits pushed on the stack. (when (not (zerop (multiple-value-setq (quotient remainder) (truncate integer (the (integer 2 35) *print-base*))))) (sub-output-integer quotient stream)) ;; Then as each recursive call unwinds, turn the digit (in remainder) ;; into a character and output the character. (write-char (code-char (if (and (> remainder 9.) (> *print-base* 10.)) (+ (if (eq *print-case* :downcase) (char-code #\a) (char-code #\A)) (- remainder 10.)) (+ (char-code #\0) remainder))) stream))) ;;;; Bignum printing ;;; Contributed by Mark Wooding, based on the algorithm in Emacs calc ;;; by David I. Bell and Landon Curt Noll. Slightly modified to be ;;; less scheme-like by rtoy. Caching by rtoy. ;;; A cache of the power lists we need for the algorithm. A power ;;; list is an alist of (2^k . r^(2^k)), where r is the desired ;;; *print-base*. The last entry in the alist should be (1 . r). (defparameter *power-lists* (make-array 37 :initial-contents (let ((r '())) (dotimes (k 37) (push (list (cons 1 k)) r)) (nreverse r)))) ;;; PRINT-BIGNUM -- internal. ;;; (defun print-bignum (big stream) (print-bignum-fast big stream) big) (defun power-list (n r) "Compute a list of pairs (2^i . r^{2^i}), stopping with the largest r^{2^i} greater than n." (declare (integer n) (fixnum r)) (do ((l nil (acons i r l)) (i 1 (* 2 i)) (r r (* r r))) ((> r n) l))) (declaim (inline digit-to-char)) (defun digit-to-char (d) "Convert digit into a character representation." (declare (fixnum d)) (labels ((offset (d b) (code-char (+ d (char-code b))))) (cond ((< d 10) (offset d #\0)) ((< d 36) (offset (- d 10) (if (eq *print-case* :downcase) #\a #\A))) (t (error _"overflow in digit-to-char"))))) (defun print-fixnum-sub (n r z s) "Print a fixnum N to stream S, maybe with leading zeros. This isn't ever-so efficient, but we probably don't need to care." (declare (fixnum n r z) (stream s)) (labels ((gen-digits (n l z) (declare (fixnum n z) (list l)) (cond ((zerop n) (dotimes (i z) (write-char #\0 s)) (dolist (d l) (write-char d s))) (t (multiple-value-bind (n d) (truncate n r) (gen-digits n (cons (digit-to-char d) l) (1- z))))))) (gen-digits n nil z))) (defun print-bignum-fast-sub (n r z s pl) "Use the power list (see power-list) PL to split N roughly in half; then print the left and right halves using (cdr PL). Make sure we count the leading zeroes correctly." (declare (integer n) (type (integer 2 36) r) (stream s) (list pl) (fixnum z)) (if (fixnump n) (print-fixnum-sub n r z s) (do ((nz (caar pl) (caar rest)) (split (cdar pl) (cdar rest)) (rest pl (rest rest))) ((<= split n) (multiple-value-bind (u v) (truncate n split) (print-bignum-fast-sub u r (if (> z nz) (- z nz) 0) s rest) (print-bignum-fast-sub v r nz s rest)))))) (defun maybe-update-power-list (n base) ;; Look up entry and see if we need to add entries to it (let ((pl (aref *power-lists* base))) (do ((index (caar pl) (caar pl)) (max (cdar pl) (cdar pl))) ((>= max n)) (setf pl (acons (* index 2) (* max max) pl))) (setf (aref *power-lists* base) pl) pl)) (defun print-bignum-fast (n s) "Primary fast bignum-printing interface. Prints integer N to stream S in radix-R. If you have a power-list then pass it in as PL." (when (minusp n) (write-char #\- s) (setf n (- n))) (print-bignum-fast-sub n *print-base* 0 s (maybe-update-power-list n *print-base*))) (defun output-ratio (ratio stream) (when *print-radix* (write-char #\# stream) (case *print-base* (2 (write-char #\b stream)) (8 (write-char #\o stream)) (16 (write-char #\x stream)) (t (write *print-base* :stream stream :radix nil :base 10) (write-char #\r stream)))) (let ((*print-radix* nil)) (output-integer (numerator ratio) stream) (write-char #\/ stream) (output-integer (denominator ratio) stream))) (defun output-complex (complex stream) (write-string "#C(" stream) (output-object (realpart complex) stream) (write-char #\space stream) (output-object (imagpart complex) stream) (write-char #\) stream)) ;;;; Float printing. ;;; ;;; Written by Bill Maddox ;;; ;;; ;;; ;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of ;;; the work for all printing of floating point numbers in the printer and in ;;; FORMAT. It converts a floating point number to a string in a free or ;;; fixed format with no exponent. The interpretation of the arguments is as ;;; follows: ;;; ;;; X - The floating point number to convert, which must not be ;;; negative. ;;; WIDTH - The preferred field width, used to determine the number ;;; of fraction digits to produce if the FDIGITS parameter ;;; is unspecified or NIL. If the non-fraction digits and the ;;; decimal point alone exceed this width, no fraction digits ;;; will be produced unless a non-NIL value of FDIGITS has been ;;; specified. Field overflow is not considerd an error at this ;;; level. ;;; FDIGITS - The number of fractional digits to produce. Insignificant ;;; trailing zeroes may be introduced as needed. May be ;;; unspecified or NIL, in which case as many digits as possible ;;; are generated, subject to the constraint that there are no ;;; trailing zeroes. ;;; SCALE - If this parameter is specified or non-NIL, then the number ;;; printed is (* x (expt 10 scale)). This scaling is exact, ;;; and cannot lose precision. ;;; FMIN - This parameter, if specified or non-NIL, is the minimum ;;; number of fraction digits which will be produced, regardless ;;; of the value of WIDTH or FDIGITS. This feature is used by ;;; the ~E format directive to prevent complete loss of ;;; significance in the printed value due to a bogus choice of ;;; scale factor. ;;; ALLOW-OVERFLOW-P - ;;; This parameter, defaulting to non-NIL, allows us to ;;; overflow any width constraint if necessary to ;;; produce a reasonable output. If NIL, then we will ;;; not exceed the width constraint, even if that means ;;; we only print out leading zeroes. Generally ;;; intended to be set by FIXED-FORMAT-AUX so we don't ;;; exceed the specified width when printing small ;;; numbers. ;;; ;;; Returns: ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) ;;; where the results have the following interpretation: ;;; ;;; DIGIT-STRING - The decimal representation of X, with decimal point. ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the ;;; decimal point. ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the ;;; decimal point. ;;; POINT-POS - The position of the digit preceding the decimal ;;; point. Zero indicates point before first digit. ;;; ROUNDOFF - True If, due to rounding, the exponent for the ;;; printed result differs from the real ;;; exponent of the number. For example, .9999 ;;; has an exponent of -1, but the printed ;;; result could be 1.000 with an exponent of 0. ;;; ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. ;;; Specifically, the decimal number printed is the closest possible ;;; approximation to the true value of the binary number to be printed from ;;; among all decimal representations with the same number of digits. In ;;; free-format output, i.e. with the number of digits unconstrained, it is ;;; guaranteed that all the information is preserved, so that a properly- ;;; rounding reader can reconstruct the original binary number, bit-for-bit, ;;; from its printed decimal representation. Furthermore, only as many digits ;;; as necessary to satisfy this condition will be printed. ;;; ;;; ;;; FLONUM-TO-DIGITS actually generates the digits for positive ;;; numbers. See below for comments. (defvar *digits* "0123456789") (defun flonum-to-string (x &key width fdigits scale fmin (num-expt 0 num-expt-p) (allow-overflow-p t)) (setf x (abs x)) (cond ((zerop x) ;;zero is a special case which float-string cannot handle (if fdigits (let ((s (make-string (1+ fdigits) :initial-element #\0))) (setf (schar s 0) #\.) (values s (length s) t (zerop fdigits) 0)) (values "." 1 t t 0))) (t (flet ((fixup-flonum-to-digits (x &optional (expt 0) position relativep) (multiple-value-bind (e s) (flonum-to-digits x position relativep) (values (- e expt) s e)))) (multiple-value-bind (e string printed-e) (if fdigits (fixup-flonum-to-digits x num-expt (+ (min (- (+ fdigits (or scale 0))) (- (or fmin 0))) num-expt)) (if (and width (> width 1)) (let ((ndigits (1- width))) #+(or) (progn (format t "ndigits = ~A~%" ndigits) (format t "scale = ~A~%" scale)) (when (and scale (< scale 0)) (setf ndigits (+ ndigits scale))) (when (minusp num-expt) (incf ndigits (- num-expt))) (fixup-flonum-to-digits x num-expt ndigits t)) (fixup-flonum-to-digits x num-expt))) (let ((stream (make-string-output-stream)) (printed-roundoff-p (and num-expt-p (/= num-expt printed-e)))) (when (and num-expt-p (/= num-expt printed-e)) ;; The actual exponent of the number differs from the ;; printed exponent. This happens for something like ;; (format nil "~11,3,2,0,'*,,'EE" .9999). With only ;; 3 fraction digits, .9999 gets rounded to 1.000 But ;; the exponent for .9999 is -1, and the exponent for ;; the printed result is actually 1. We need to ;; decrement e by 1 to account for this. (decf e)) #+(or) (progn (format t "e = ~S~%" e) (format t "roundoff = ~S~%" printed-roundoff-p)) (incf e (or scale 0)) (if (plusp e) (progn (write-string string stream :end (min (length string) e)) (dotimes (i (- e (length string))) (write-char #\0 stream)) (write-char #\. stream) (write-string string stream :start (min (length string) e)) (when fdigits (dotimes (i (- fdigits (- (length string) (min (length string) e)))) (write-char #\0 stream)))) (progn (write-string "." stream) ;; Write out the leading zeroes. If fmin is set, ;; we need all of them. But if fdigits is given ;; and is smaller than -e, we only want fdigits ;; to be output. That way we don't print too ;; many leading zeroes if the number is too ;; small. ;; ;; Also print them all out if :allow-overflow-p ;; is set or there's no width constraint. #+(or) (progn (format t "fmin = ~S~%" fmin) (format t "fdigits = ~S~%" fdigits) (format t "width = ~S~%" width) (when width (format t "min = ~S~%" (min (- e) width)))) (let ((leading-zeros (if (or fmin (null fdigits)) (if (or allow-overflow-p (null width)) (- e) (min (- e) (1- width))) (min (- e) fdigits)))) (dotimes (i leading-zeros) (write-char #\0 stream)) ;; If we're out of room (because fdigits is too ;; small), don't print out our string. This ;; fixes things like (format nil "~,2f" 0.001). ;; We should print ".00", not ".001". But if ;; fmin is set, we want to print out something. (when (or (null fdigits) (plusp (+ e fdigits)) fmin) ;; But only print the whole string if there's ;; no width constraint or if we're allowed to ;; exceed the width. (if (or allow-overflow-p (null width)) (write-string string stream) (write-string string stream :end (min (- width leading-zeros 1) (length string))))) (when fdigits (dotimes (i (+ fdigits e (- (length string)))) (write-char #\0 stream)))))) (let ((string (get-output-stream-string stream))) (values string (length string) (char= (char string 0) #\.) (char= (char string (1- (length string))) #\.) (position #\. string) printed-roundoff-p)))))))) ;;;; Entry point for the float printer. ;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC, ;;; etc. The argument is printed free-format, in either exponential or ;;; non-exponential notation, depending on its magnitude. ;;; ;;; NOTE: When a number is to be printed in exponential format, it is scaled in ;;; floating point. Since precision may be lost in this process, the ;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The ;;; difficulty is that FLONUM-TO-STRING performs extensive computations with ;;; integers of similar magnitude to that of the number being printed. For ;;; large exponents, the bignums really get out of hand. If bignum arithmetic ;;; becomes reasonably fast and the exponent range is not too large, then it ;;; might become attractive to handle exponential notation with the same ;;; accuracy as non-exponential notation, using the method described in the ;;; Steele and White paper. ;;; PRINT-FLOAT-EXPONENT -- Internal ;;; ;;; Print the appropriate exponent marker for X and the specified exponent. ;;; (defun print-float-exponent (x exp stream) (declare (float x) (integer exp) (stream stream)) (let ((*print-radix* nil)) ;; CLHS 22.3.3.2 for ~E says (near the bottom) that ;; ;; If all of w, d, and e are omitted, then the effect is to ;; print the value using ordinary free-format ;; exponential-notation output; prin1 uses a similar format for ;; any non-zero number whose magnitude is less than 10^-3 or ;; greater than or equal to 10^7. The only difference is that ;; the ~E directive always prints a plus or minus sign in front ;; of the exponent, while prin1 omits the plus sign if the ;; exponent is non-negative. ;; ;; So we don't want a + sign for the exponent. (if (typep x *read-default-float-format*) (unless (eql exp 0) (format stream "e~D" exp)) (format stream "~C~D" (etypecase x (single-float #\f) (double-float #\d) (short-float #\s) (long-float #\L) #+double-double (double-double-float #\w)) exp)))) ;;; FLOAT-FORMAT-NAME -- Internal ;;; ;;; Return the string name of X's float format. ;;; (defun float-format-name (x) (declare (float x)) (etypecase x (single-float "SINGLE-FLOAT") (double-float "DOUBLE-FLOAT") (short-float "SHORT-FLOAT") (long-float "LONG-FLOAT") #+double-double (double-double-float "DOUBLE-DOUBLE-FLOAT"))) ;;; OUTPUT-FLOAT-INFINITY -- Internal ;;; ;;; Write out an infinity using #. notation, or flame out if ;;; *print-readably* is true and *read-eval* is false. ;;; (defun output-float-infinity (x stream) (declare (float x) (stream stream)) (cond (*read-eval* (write-string "#." stream)) (*print-readably* (error 'print-not-readable :object x)) (t (write-string "#<" stream))) (write-string "EXT:" stream) (write-string (float-format-name x) stream) (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-") stream) (write-string "INFINITY" stream) (unless *read-eval* (write-string ">" stream))) ;;; OUTPUT-FLOAT-NAN -- Internal ;;; ;;; Output a #< NaN or die trying. ;;; (defun output-float-nan (x stream) (print-unreadable-object (x stream) (write-string (float-format-name x) stream) (write-string (if (float-signaling-nan-p x) " Signaling" " Quiet") stream) (write-string " NaN" stream))) (defconstant output-float-free-format-exponent-min -3 "Minimum power of 10 that allows the float printer to use free format, instead of exponential format. See section 22.1.3.1.3: Printing Floats in the ANSI CL standard.") (defconstant output-float-free-format-exponent-max 8 "Maximum power of 10 that allows the float printer to use free format, instead of exponential format. See section 22.1.3.1.3: Printing Floats in the ANSI CL standard.") ;;; OUTPUT-FLOAT -- Internal ;;; ;;; Functioned called by OUTPUT-OBJECT to handle floats. ;;; (defun output-float (x stream) (cond ((float-infinity-p x) (output-float-infinity x stream)) ((float-nan-p x) (output-float-nan x stream)) #+(and nil double-double) ((typep x 'double-double-float) ;; This is a temporary hack until we get more double-double float ;; stuff in place so that we don't need this. And being able to ;; print double-double's now is quite handy while we debug the ;; rest of the code. (output-double-double-float x stream)) (t (let ((x (cond ((minusp (float-sign x)) (write-char #\- stream) (- x)) (t x)))) (cond ((zerop x) (write-string "0.0" stream) (print-float-exponent x 0 stream)) (t (output-float-aux x stream output-float-free-format-exponent-min output-float-free-format-exponent-max))))))) #+double-double (defun output-double-double-float (x stream) (dd->string (kernel:double-double-hi x) (kernel:double-double-lo x) stream)) ;;; The code below for printing double-double's was written by Richard ;;; Fateman. Used with permission. #+double-double (defvar *dd-digits-to-show* 33) #+double-double (defun dd->lisp (a0 a1) "Convert a DD number to a lisp rational" (declare (double-float a0 a1)) (+ (rational a0) (rational a1))) #+double-double ;; r rational number >=0 ;; n number of digits (defun decimalize (r n &optional (base 10)) (let* ((expon (if (= r 0) 0 (floor (cl::log (cl::abs r) base)))) (frac (round (* (cl::abs r) (expt base (- n expon)))))) (values (signum r) frac (if (= frac 0) 0 (cl::1+ expon))))) #+double-double (defun dd->string (x0 x1 stream) "Print out a double-double to a string" (cond ((and (zerop x0) (zerop x1)) (format stream "0.dd0")) (t (multiple-value-bind (s r e h) (decimalize (dd->lisp x0 x1) *dd-digits-to-show* 10) ;; This is slightly modified from Richard Fateman's version to ;; print numbers in the format x.xxddee instead of 0.xxddee. (let ((out (string-right-trim "0" (subseq (setf h (format nil "~A~%" r)) 0 (min (length h) *dd-digits-to-show*))))) (format stream "~A~A.~Aw~S" (if (< s 0) "-" "") (aref out 0) (subseq out 1) (1- e))))))) ;; Smallest possible (unbiased) exponents (defconstant double-float-min-e (nth-value 1 (decode-float least-positive-double-float))) (defconstant single-float-min-e (nth-value 1 (decode-float least-positive-single-float))) #+double-double (defconstant double-double-float-min-e double-float-min-e) ;; Exact powers of ten. Must be large enough to cover the range from ;; least-positive-double-float to most-positive-double-float (declaim (type (simple-array integer (400)) *powers-of-ten*)) (defparameter *powers-of-ten* (make-array 400 :initial-contents (let (p) (dotimes (k 400 (nreverse p)) (push (expt 10 k) p))))) ;;; Implementation of Figure 1 from "Printing Floating-Point Numbers ;;; Quickly and Accurately", by Burger and Dybvig, 1996. As the ;;; implementation of the Dragon algorithm above says: "DO NOT EVEN ;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE ;;; PAPER!" This is a more idiomatic Lisp translation by CSR of the ;;; scheme implementation in that paper. ;;; (defun flonum-to-digits (v &optional position relativep) ;; V is the number to be printed. If RELATIVEP is NIL, POSITION is ;; the number of digits to the left of the decimal point where we ;; want to stop printing. If RELATIVEP is non-NIL, POSITION is the ;; total number of digits we want printed. ;; ;; Two values are returned: k, and the digit string, without a ;; decimal point. k is the index into the string, before which the ;; decimal point would go. (let ((print-base 10) ; B (float-radix 2) ; b (float-digits (float-digits v)) ; p (min-e (etypecase v (single-float single-float-min-e) (double-float double-float-min-e) #+double-double (double-double-float double-double-float-min-e)))) (multiple-value-bind (f e) (integer-decode-float v) (let ( ;; FIXME: these even tests assume normal IEEE rounding ;; mode. I wonder if we should cater for non-normal? (high-ok (evenp f)) (low-ok (evenp f)) (result (make-array 50 :element-type 'base-char :fill-pointer 0 :adjustable t))) (labels ((flog (x) (declare (type (float (0.0)) x)) (let ((xd (etypecase x (single-float (float x 1d0)) (double-float x) #+double-double (double-double-float (double-double-hi x))))) (ceiling (- (the (double-float -400d0 400d0) (log xd 10d0)) 1d-10)))) (fixup (r s m+ m- k) (if (if high-ok (>= (+ r m+) s) (> (+ r m+) s)) (values (+ k 1) (generate r (* s print-base) m+ m-)) (values k (generate r s m+ m-)))) (scale (r s m+ m-) (let* ((est (flog v)) (scale (the integer (aref lisp::*powers-of-ten* (abs est))))) (if (>= est 0) (fixup r (* s scale) m+ m- est) (fixup (* r scale) s (* m+ scale) (* m- scale) est)))) (generate (r s m+ m-) (multiple-value-bind (d r) (truncate (* r print-base) s) (let ((m+ (* m+ print-base)) (m- (* m- print-base))) (let ((tc1 (or (< r m-) (and low-ok (= r m-)))) (tc2 (let ((test (+ r m+))) (or (> test s) (and high-ok (= test s)))))) (cond ((and (not tc1) (not tc2)) (vector-push-extend (char *digits* d) result) ;; FIXME sucky tail recursion. This whole ;; kaboodle should be DO*/LOOPified. (generate r s m+ m-)) ;; pedantically keeping all the conditions ;; in so that we can move them around. ((and (not tc1) tc2) (vector-push-extend (char *digits* (1+ d)) result) result) ((and tc1 (not tc2)) (vector-push-extend (char *digits* d) result) result) ((and tc1 tc2) (vector-push-extend (char *digits* (if (< (* r 2) s) d (1+ d))) result) result))))))) (let (r s m+ m-) (if (>= e 0) (let* ((be (expt float-radix e)) (be1 (* be float-radix))) (if (/= f (expt float-radix (1- float-digits))) (setf r (* f be 2) s 2 m+ be m- be) (setf r (* f be1 2) s (* float-radix 2) m+ be1 m- be))) (if (or (= e min-e) (/= f (expt float-radix (1- float-digits)))) (setf r (* f 2) s (* (expt float-radix (- e)) 2) m+ 1 m- 1) (setf r (* f float-radix 2) s (* (expt float-radix (- 1 e)) 2) m+ float-radix m- 1))) (when position (flet ((expt-ten (e) (if (> (abs e) (length *powers-of-ten*)) (expt 10 e) (if (minusp e) (/ (aref *powers-of-ten* (- e))) (aref *powers-of-ten* e))))) (when relativep (let ((r+m (+ r m+))) ;;(format t "r, s = ~A, ~A~%" r s) (do ((k 0 (1+ k)) ;; running out of letters here (l 1 (* l print-base))) ((>= (* s l) r+m) ;; k is now \hat{k} ;;(format t "r>s, k = ~A~%" k) (if (< (+ r (* s (/ (expt-ten (- k position)) 2))) (* s (expt-ten k))) (setf position (- k position)) (setf position (- k position 1))))))) (let ((low (max m- (/ (* s (expt-ten position)) 2))) (high (max m+ (/ (* s (expt-ten position)) 2)))) (when (<= m- low) (setf m- low) (setf low-ok t)) (when (<= m+ high) (setf m+ high) (setf high-ok t))))) (scale r s m+ m-))))))) (defun output-float-aux (x stream e-min e-max) (multiple-value-bind (e string) (flonum-to-digits x) (cond ((< e-min e e-max) ;; free format (cond ((plusp e) (write-string string stream :end (min (length string) e)) (dotimes (i (- e (length string))) (write-char #\0 stream)) (write-char #\. stream) (write-string string stream :start (min (length string) e)) (when (<= (length string) e) (write-char #\0 stream)) (print-float-exponent x 0 stream)) (t (write-string "0." stream) (dotimes (i (- e)) (write-char #\0 stream)) (write-string string stream) (print-float-exponent x 0 stream)))) (t ;; Exponential format (write-string string stream :end 1) (write-char #\. stream) (write-string string stream :start 1) ;; CLHS 22.1.3.1.3 says at least one digit must be printed ;; after the decimal point. (when (= (length string) 1) (write-char #\0 stream)) (print-float-exponent x (1- e) stream))))) ;;;; Other leaf objects. ;;; OUTPUT-CHARACTER -- Internal ;;; ;;; If *print-escape* is false, just do a WRITE-CHAR, otherwise output the ;;; character name or the character in the #\char format. ;;; (defun output-character (char stream) (if (or *print-escape* *print-readably*) (let ((name (char-name char))) (write-string "#\\" stream) ;; CLHS 22.1.3.2 says graphic characters are not printed using ;; the character name. (if (and name (not (graphic-char-p char))) (quote-string name stream) (write-char char stream))) (write-char char stream))) (defun output-sap (sap stream) (declare (type system-area-pointer sap)) (cond (*read-eval* (format stream "#.(~S #x~8,'0X)" 'int-sap (sap-int sap))) (t (print-unreadable-object (sap stream) (format stream "System-Area-Pointer: #x~8,'0X" (sap-int sap)))))) (defun output-weak-pointer (weak-pointer stream) (declare (type weak-pointer weak-pointer)) (print-unreadable-object (weak-pointer stream :identity t) (multiple-value-bind (value validp) (weak-pointer-value weak-pointer) (cond (validp (write-string _"Weak Pointer: " stream) (write value :stream stream)) (t (write-string _"Broken Weak Pointer" stream)))))) (defun output-code-component (component stream) (print-unreadable-object (component stream :identity t) (let ((dinfo (%code-debug-info component))) (cond ((eq dinfo :bogus-lra) (write-string _"Bogus Code Object" stream)) (t (write-string _"Code Object" stream) (when dinfo (write-char #\space stream) (output-object (c::debug-info-name dinfo) stream))))))) (defun output-lra (lra stream) (print-unreadable-object (lra stream :identity t) (write-string _"Return PC Object" stream))) (defun output-fdefn (fdefn stream) (print-unreadable-object (fdefn stream) (write-string _"FDEFINITION object for " stream) (output-object (fdefn-name fdefn) stream))) #+gencgc (defun output-scavhook (scav stream) (print-unreadable-object (scav stream :identity t :type t))) ;;;; Various flavors of function pointers. ;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed ;;; representation of function objects. It is called from OUTPUT-RANDOM ;;; below. (defun output-function-object (subr stream) (write-string _"Function " stream) (prin1 (%function-name subr) stream)) ;;; OUTPUT-INTERPRETED-FUNCTION -- Internal ;;; ;;; Print the name or definition of an interpreted function. ;;; (defun output-interpreted-function (subr stream) (multiple-value-bind (def ignore name) (eval:interpreted-function-lambda-expression subr) (declare (ignore ignore)) (let ((*print-level* 3)) (format stream _"Interpreted Function ~S" (or name def))))) (defun output-function (function stream) (print-unreadable-object (function stream :identity t) (case (function-subtype function) ((#.vm:function-header-type #.vm:closure-function-header-type) (output-function-object function stream)) (#.vm:byte-code-function-type (write-string _"Byte Compiled Function" stream)) (#.vm:byte-code-closure-type (write-string _"Byte Compiled Closure" stream)) (#.vm:closure-header-type (cond ((eval:interpreted-function-p function) (output-interpreted-function function stream)) (t (write-string _"Closure Over " stream) (output-function-object (%closure-function function) stream)))) (t (write-string _"Unknown Function" stream))))) ;;;; Catch-all for unknown things. (defun output-random (object stream) (print-unreadable-object (object stream :identity t) (let ((lowtag (get-lowtag object))) (case lowtag (#.vm:other-pointer-type (let ((type (get-type object))) (case type (#.vm:value-cell-header-type (write-string _"Value Cell " stream) (output-object (c:value-cell-ref object) stream)) (t (write-string _"Unknown Pointer Object, type=" stream) (let ((*print-base* 16) (*print-radix* t)) (output-integer type stream)))))) ((#.vm:function-pointer-type #.vm:instance-pointer-type #.vm:list-pointer-type) (write-string _"Unknown Pointer Object, type=" stream)) (t (case (get-type object) (#.vm:unbound-marker-type (write-string _"Unbound Marker" stream)) (t (write-string _"Unknown Immediate Object, lowtag=" stream) (let ((*print-base* 2) (*print-radix* t)) (output-integer lowtag stream)) (write-string _", type=" stream) (let ((*print-base* 16) (*print-radix* t)) (output-integer (get-type object) stream))))))))) ;;; Function to initialize character-attributes. The full utf-16 set ;;; is initialized. #+unicode (defun reinit-char-attributes () (unless (unicode-data-loaded-p) (unless (probe-file *unidata-path*) (cerror _"Continue anyway" _"Cannot find ~S, so unicode support is not available" *unidata-path*) (return-from reinit-char-attributes nil))) (flet ((set-bit (char bit) (let ((code (char-code char))) (setf (aref character-attributes code) (logior bit (aref character-attributes code)))))) (fill character-attributes 0) (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} #\? #\< #\>)) (set-bit char other-attribute)) (dotimes (i 10) (set-bit (digit-char i) number-attribute)) (do ((code (char-code #\A) (1+ code)) (end (char-code #\Z))) ((> code end)) (declare (fixnum code end)) (set-bit (code-char code) uppercase-attribute) (set-bit (char-downcase (code-char code)) lowercase-attribute)) (set-bit #\- sign-attribute) (set-bit #\+ sign-attribute) (set-bit #\^ extension-attribute) (set-bit #\_ extension-attribute) (set-bit #\. dot-attribute) (set-bit #\/ slash-attribute) (set-bit #\` funny-attribute) (set-bit #\| funny-attribute) ;; For everything else, derive the attribute from the Unicode ;; properties of the character. (dotimes (i char-code-limit) (when (zerop (aref character-attributes i)) (let* ((char (code-char i))) ;; What about surrogate pairs? What should we do about them? (cond ((upper-case-p char) (set-bit char uppercase-attribute)) ((lower-case-p char) (set-bit char lowercase-attribute)) ((or (= (unicode-category i) +unicode-category-other+) (= (ash (unicode-category i) -4) 6)) ;; Includes characters without case and all Unicode symbols (set-bit char othercase-attribute)) (t (setf (aref character-attributes i) funny-attribute)))))))) #+unicode (pushnew #'reinit-char-attributes ext:*after-save-initializations*) cmucl-21a/src/code/profile.lisp000066400000000000000000001030421260377556400166130ustar00rootroot00000000000000;;; -*- Package: Profile -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/profile.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Description: Simple profiling facility. ;;; ;;; Author: Skef Wholey, Rob MacLachlan ;;; ;;; Compatibility: Runs in any valid Common Lisp. Three small implementation- ;;; dependent changes can be made to improve performance and prettiness. ;;; ;;; Dependencies: The macro Quickly-Get-Time and the function ;;; Required-Arguments should probably be tailored to the implementation for ;;; the best results. They will default to working, albeit inefficent, forms ;;; in non-CMU implementations. The Total-Consing macro is used to profile ;;; consing: in unknown implementations 0 will be used. ;;; See the "Implementation Parameters" section. ;;; ;;; Note: a timing overhead factor is computed when REPORT-TIME is first ;;; called. This will be incorrect if profiling code is run in a different ;;; environment than the first call to REPORT-TIME. For example, saving a core ;;; image on a high performance machine and running it on a low performance one ;;; will result in use of an erroneously small timing overhead factor. In CMU ;;; CL, this cache is invalidated when a core is saved. ;;; (intl:textdomain "cmucl") (defpackage "PROFILE" (:use :common-lisp :ext :fwrappers) (:export *timed-functions* profile profile-all unprofile reset-time report-time report-time-custom *default-report-time-printfunction* with-spacereport print-spacereports reset-spacereports delete-spacereports *insert-spacereports* *no-calls* *no-calls-limit*)) (in-package "PROFILE") ;;;; Implementation dependent interfaces: (defconstant quick-time-units-per-second internal-time-units-per-second) (defmacro quickly-get-time () `(the time-type (get-internal-run-time))) ;;; ;;; The type of the result from quickly-get-time. ;;; (deftype time-type () '(unsigned-byte 29)) ;;; ;;; Return two values: the first is the number of required arguments, ;;; and the second is T iff NAME has any non-required arguments ;;; (e.g. &OPTIONAL, &REST, &KEY). ;;; (defun required-arguments (name) (let ((type (ext:info function type name))) (cond ((not (kernel:function-type-p type)) (values 0 t)) (t (values (length (kernel:function-type-required type)) (if (or (kernel:function-type-optional type) (kernel:function-type-keyp type) (kernel:function-type-rest type)) t nil)))))) ;;; ;;; TOTAL-CONSING is called to find the total number of bytes consed ;;; since the beginning of time. ;;; (declaim (inline total-consing)) (defun total-consing () (ext:get-bytes-consed-dfixnum)) ;;; ;;; The type of the result of TOTAL-CONSING. ;;; (deftype consing-type () '(and fixnum unsigned-byte)) ;;; ;;; On the CMUCL x86 port the return address is represented as a SAP ;;; and to save the costly calculation of the SAPs code object the ;;; profiler maintains callers as SAPs. These SAPs will become invalid ;;; if a caller code object moves, so this should be prevented by the ;;; use of purify or by moving code objects into an older generation ;;; when using GENCGC. ;;; (defmacro get-caller-info () `(nth-value 1 (kernel:%caller-frame-and-pc))) #-x86 (defun print-caller-info (info stream) (prin1 (kernel:lra-code-header info) stream)) #+x86 (defun print-caller-info (info stream) (prin1 (nth-value 1 (di::compute-lra-data-from-pc info)) stream)) ;;;; Global data structures: (defvar *timed-functions* () "List of functions that are currently being timed.") (defvar *no-calls* nil "A list of profiled functions which weren't called.") (defvar *no-calls-limit* 20 "If the number of profiled functions that were not called is less than this, the functions are listed. If NIL, then always list the functions.") ;;; ;;; This is stored as user-data of profile fwrappers. ;;; (defstruct (profile-info (:conc-name pi-) (:constructor make-profile-info (function-name callers-p))) ;; ;; The name of the function being profiled. function-name ;; ;; True if :CALLERS arg was given to PROFILE. (callers-p nil :type boolean) ;; ;; Various counters for profiling. (count 0 :type fixnum) (time 0 :type time-type) (consed-h 0 :type dfixnum:dfparttype) (consed-l 0 :type dfixnum:dfparttype) (consed-w/c-h 0 :type dfixnum:dfparttype) (consed-w/c-l 0 :type dfixnum:dfparttype) (profile 0 :type integer) (callers () :type list)) ;;; ;;; Reset counters of the given PROFILE-INFO ;;; (defun reset-profile-info (info) (setf (pi-count info) 0 (pi-time info) 0 (pi-consed-h info) 0 (pi-consed-l info) 0 (pi-consed-w/c-h info) 0 (pi-consed-w/c-l info) 0 (pi-profile info) 0 (pi-callers info) ())) ;;; ;;; Return various profiling information from INFO as multiple values. ;;; (defun profile-info-profiling-values (info) (values (pi-count info) (pi-time info) (dfixnum:dfixnum-pair-integer (pi-consed-h info) (pi-consed-l info)) (dfixnum:dfixnum-pair-integer (pi-consed-w/c-h info) (pi-consed-w/c-l info)) (pi-profile info) (pi-callers info))) ;;; ;;; These variables are used to subtract out the time and consing for ;;; recursive and other dynamically nested profiled calls. The total ;;; resource consumed for each nested call is added into the ;;; appropriate variable. When the outer function returns, these ;;; amounts are subtracted from the total. ;;; ;;; *ENCLOSED-CONSING-H* and *ENCLOSED-CONSING-L* represent the total ;;; consing as a pair of fixnum-sized integers to reduce consing and ;;; allow for about 2^58 bytes of total consing. (Assumes positive ;;; fixnums are 29 bits long). ;;; (defvar *enclosed-time* 0) (defvar *enclosed-consing-h* 0) (defvar *enclosed-consing-l* 0) (defvar *enclosed-profilings* 0) (declaim (type time-type *enclosed-time*)) (declaim (type dfixnum:dfparttype *enclosed-consing-h*)) (declaim (type dfixnum:dfparttype *enclosed-consing-l*)) (declaim (fixnum *enclosed-profilings*)) ;;; ;;; The number of seconds a bare function call takes. Factored into ;;; the other overheads, but not used for itself. ;;; (defvar *call-overhead*) ;;; ;;; The number of seconds that will be charged to a profiled function ;;; due to the profiling code. ;;; (defvar *internal-profile-overhead*) ;;; ;;; The number of seconds of overhead for profiling that a single ;;; profiled call adds to the total runtime for the program. ;;; (defvar *total-profile-overhead*) (declaim (single-float *call-overhead* *internal-profile-overhead* *total-profile-overhead*)) ;;;; Profile encapsulations: (eval-when (:compile-toplevel :load-toplevel :execute) ;;; ;;; Names of fwrappers look like (PROFILE ). ;;; is the number of required parameters, is ;;; true if the fwrapper is for functions with optional arguments. ;;; (define-function-name-syntax profile (name) (when (integerp (cadr name)) (values t 'profile))) ;;; ;;; Return the profile fwrapper name for profiling a function ;;; with NREQ required arguments and optional arguments according ;;; to OPTIONALS-P. ;;; (defun make-profile-fwrapper-name (nreq optionals-p) `(profile ,nreq ,optionals-p)) ;;; ;;; Return a DEFINE-FWRAPPER form for profiling a function with ;;; arguments according to NREQ and OPTIONALS-P. ;;; (defun make-profile-fwrapper (nreq optionals-p) (let ((req (loop repeat nreq collect (gensym))) (name (make-profile-fwrapper-name nreq optionals-p))) `(define-fwrapper ,name (,@req ,@(if optionals-p `(&rest .rest.))) (let* ((info (fwrapper-user-data fwrapper)) (fn-name (pi-function-name info)) (fdefn (lisp::fdefinition-object fn-name nil))) ;; ;; "Deactivate" the profile fwrapper for the time it is ;; running to ease profiling of functions used in the ;; implementation of PROFILE itself. (letf (((lisp::fdefn-function fdefn) (fwrapper-next fwrapper))) (incf (pi-count info)) ;; ;; If :CALLERS was specified for profiling, record caller ;; information. (when (pi-callers-p info) (let ((caller (get-caller-info))) (do ((prev nil current) (current (pi-callers info) (cdr current))) ((null current) (push (cons caller 1) (pi-callers info))) (let ((old-caller-info (car current))) (when (progn #-x86 (eq caller (car old-caller-info)) #+x86 (sys:sap= caller (car old-caller-info))) (if prev (setf (cdr prev) (cdr current)) (setf (pi-callers info) (cdr current))) (setf (cdr old-caller-info) (the fixnum (+ (cdr old-caller-info) 1))) (setf (cdr current) (pi-callers info)) (setf (pi-callers info) current) (return)))))) (let ((time-inc 0) (cons-inc-h 0) (cons-inc-l 0) (profile-inc 0)) (declare (type time-type time-inc) (type dfixnum:dfparttype cons-inc-h cons-inc-l) (fixnum profile-inc)) (multiple-value-prog1 (let ((start-time (quickly-get-time)) (start-consed-h 0) (start-consed-l 0) (end-consed-h 0) (end-consed-l 0) (*enclosed-time* 0) (*enclosed-consing-h* 0) (*enclosed-consing-l* 0) (*enclosed-profilings* 0)) (dfixnum:dfixnum-set-pair start-consed-h start-consed-l (total-consing)) (multiple-value-prog1 (call-next-function) (setq time-inc #-BSD (- (quickly-get-time) start-time) #+BSD (max (- (quickly-get-time) start-time) 0)) ;; How much did we cons so far? (dfixnum:dfixnum-set-pair end-consed-h end-consed-l (total-consing)) (dfixnum:dfixnum-copy-pair cons-inc-h cons-inc-l end-consed-h end-consed-l) (dfixnum:dfixnum-dec-pair cons-inc-h cons-inc-l start-consed-h start-consed-l) ;; (incf consed (- cons-inc *enclosed-consing*)) (dfixnum:dfixnum-inc-pair (pi-consed-h info) (pi-consed-l info) cons-inc-h cons-inc-l) (dfixnum:dfixnum-inc-pair (pi-consed-w/c-h info) (pi-consed-w/c-l info) cons-inc-h cons-inc-l) (setq profile-inc *enclosed-profilings*) (incf (pi-time info) (the time-type #-BSD (- time-inc *enclosed-time*) #+BSD (max (- time-inc *enclosed-time*) 0))) (dfixnum:dfixnum-dec-pair (pi-consed-h info) (pi-consed-l info) *enclosed-consing-h* *enclosed-consing-l*) (incf (pi-profile info) profile-inc))) (incf *enclosed-time* time-inc) ;; *enclosed-consing* = *enclosed-consing + cons-inc (dfixnum:dfixnum-inc-pair *enclosed-consing-h* *enclosed-consing-l* cons-inc-h cons-inc-l))))))))) ;;; ;;; Pre-define some profile fwrappers. ;;; (macrolet ((def-profile-fwrapper (nreq) `(progn ,(make-profile-fwrapper nreq t) ,(make-profile-fwrapper nreq nil)))) (def-profile-fwrapper 0) (def-profile-fwrapper 1) (def-profile-fwrapper 2) (def-profile-fwrapper 3)) #+(or) (defun ensure-profile-fwrapper (nreq optionals-p) "Ensure that a profile fwrapper for functions with NREQ required arguments and optional arguments according to OPTIONALS-P exists. Return the name of that fwrapper." (let ((name (make-profile-fwrapper-name nreq optionals-p))) (unless (fboundp name) (without-package-locks (eval (make-profile-fwrapper nreq optionals-p)) (compile name))) name)) (defun ensure-profile-fwrapper (nreq optionals-p) "Ensure that a profile fwrapper for functions with NREQ required arguments and optional arguments according to OPTIONALS-P exists. Return the name of that fwrapper." (let ((name (make-profile-fwrapper-name nreq optionals-p))) (unless (fboundp name) (without-package-locks ;; I (rtoy) do not know why the above version does not work, ;; but this seems to work better. (destructuring-bind (def name args &body body) (macroexpand-1 (make-profile-fwrapper nreq optionals-p)) (declare (ignore def)) (compile name `(lambda ,args ,@body))))) name)) (defun find-profile-fwrapper (name) "Return the profile FWRAPPER object on function NAME, if any." (find-fwrapper name :type 'profile)) (defun pi-or-lose (name) "Return the PROFILE-INFO for function NAME. Signal an error if NAME is not profiled." (let ((f (find-profile-fwrapper name))) (if f (fwrapper-user-data f) (error "No profile info for ~s" name)))) ;;; Interfaces: ;;; PROFILE-1-FUNCTION -- Internal ;;; ;;; Profile the function Name. If already profiled, unprofile first. ;;; (defun profile-1-function (name callers-p) (if (fboundp name) (multiple-value-bind (nreq optionals-p) (required-arguments name) (when (find-profile-fwrapper name) (warn "~s already profiled, unprofiling it first" name) (unprofile-1-function name)) (let ((ctor (ensure-profile-fwrapper nreq optionals-p))) (fwrap name (fdefinition ctor) :type 'profile :user-data (make-profile-info name callers-p)) (push name *timed-functions*))) (warn "Ignoring undefined function ~s" name))) ;;; PROFILE -- Public ;;; (defmacro profile (&rest names) "PROFILE Name* Wraps profiling code around the named functions. As in TRACE, the names are not evaluated. If a function is already profiled, then unprofile and reprofile (useful to notice function redefinition.) If a name is undefined, then we give a warning and ignore it. CLOS methods can be profiled by specifying names of the form (METHOD * (*)), like in TRACE. :METHODS Function-Form is a way of specifying that all methods of a generic functions should be profiled. The Function-Form is evaluated immediately, and the methods of the resulting generic function are profiled. If :CALLERS T appears, subsequent names have counts of the most common calling functions recorded. See also UNPROFILE, REPORT-TIME and RESET-TIME." (collect ((binds) (forms)) (let ((names names) (callers nil)) (loop (unless names (return)) (let ((name (pop names))) (cond ((eq name :callers) (setq callers (not (null (pop names))))) ;; ;; Method functions. #+pcl ((and (consp name) (eq 'method (car name))) (let ((fast-name `(pcl::fast-method ,@(cdr name)))) (forms `(when (fboundp ',name) (profile-1-function ',name ,callers) (reinitialize-method-function ',name))) (forms `(when (fboundp ',fast-name) (profile-1-function ',fast-name ,callers) (reinitialize-method-function ',fast-name))))) ;; ;; All method of a generic function. #+pcl ((eq :methods name) (let ((tem (gensym))) (binds `(,tem ,(pop names))) (forms `(dolist (name (debug::all-method-function-names ,tem)) (when (fboundp name) (profile-1-function name ,callers) (reinitialize-method-function name)))))) (t (forms `(profile-1-function ',name ,callers)))))) (if (binds) `(let ,(binds) ,@(forms) (values)) `(progn ,@(forms) (values)))))) ;;; PROFILE-ALL -- Public ;;; ;;; Add profiling to all symbols in the given package. ;;; (defun profile-all (&key (package *package*) (callers-p nil) (methods nil)) "PROFILE-ALL Wraps profiling code around all functions in PACKAGE, which defaults to *PACKAGE*. If a function is already profiled, then unprofile and reprofile (useful to notice function redefinition.) If a name is undefined, then we give a warning and ignore it. If CALLERS-P is T names have counts of the most common calling functions recorded. When called with arguments :METHODS T, profile all methods of all generic function having names in the given package. Generic functions themselves, that is, their dispatch functions, are left alone. See also UNPROFILE, REPORT-TIME and RESET-TIME. " (let ((package (if (packagep package) package (find-package package)))) (do-symbols (symbol package (values)) (when (and (eq (symbol-package symbol) package) (fboundp symbol) (not (special-operator-p symbol)) (or (not methods) (not (typep (fdefinition symbol) 'generic-function)))) (profile-1-function symbol callers-p))) ;; ;; Profile all method functions whose generic function name ;; is in the package. (when methods (dolist (name (debug::all-method-functions-in-package package)) (when (fboundp name) (profile-1-function name callers-p) (reinitialize-method-function name)))))) ;;; UNPROFILE -- Public ;;; (defmacro unprofile (&rest names) "Unwraps the profiling code around the named functions. Names defaults to the list of all currently profiled functions." (collect ((binds) (forms)) (let ((names (or names *timed-functions*))) (loop (unless names (return)) (let ((name (pop names))) (cond #+pcl ((and (consp name) (member (car name) '(method pcl::fast-method))) (let ((name `(method ,@(cdr name))) (fast-name `(pcl::fast-method ,@(cdr name)))) (forms `(when (fboundp ',name) (unprofile-1-function ',name) (reinitialize-method-function ',name))) (forms `(when (fboundp ',fast-name) (unprofile-1-function ',fast-name) (reinitialize-method-function ',fast-name))))) #+pcl ((eq :methods name) (let ((tem (gensym))) (binds `(,tem ,(pop names))) (forms `(dolist (name (debug::all-method-function-names ,tem)) (when (fboundp name) (unprofile-1-function name) (reinitialize-method-function name)))))) (t (forms `(unprofile-1-function ',name)))))) (if (binds) `(let ,(binds) ,@(forms) (values)) `(progn ,@(forms) (values)))))) ;;; UNPROFILE-1-FUNCTION -- Internal ;;; (defun unprofile-1-function (name) (funwrap name :type 'profile) (setq *timed-functions* (delete name *timed-functions* :test #'equal))) (defun re-profile-redefined-function (name new-value) (declare (ignore new-value)) (let (f) (when (and (fboundp name) (setq f (find-profile-fwrapper name))) (profile-1-function name (pi-callers-p (fwrapper-user-data f)))))) (push #'re-profile-redefined-function ext:*setf-fdefinition-hook*) ;;; COMPENSATE-TIME -- Internal ;;; ;;; Return our best guess for the run time in a function, subtracting out ;;; factors for profiling overhead. We subtract out the internal overhead for ;;; each call to this function, since the internal overhead is the part of the ;;; profiling overhead for a function that is charged to that function. ;;; ;;; We also subtract out a factor for each call to a profiled function ;;; within this profiled function. This factor is the total profiling overhead ;;; *minus the internal overhead*. We don't subtract out the internal ;;; overhead, since it was already subtracted when the nested profiled ;;; functions subtracted their running time from the time for the enclosing ;;; function. ;;; (defun compensate-time (calls time profile) (let ((compensated (- (/ (float time) (float quick-time-units-per-second)) (* *internal-profile-overhead* (float calls)) (* (- *total-profile-overhead* *internal-profile-overhead*) (float profile))))) (if (minusp compensated) 0.0 compensated))) (defstruct width-info cons calls time time/call cons/call) ;; Compute and return the width of the field needed to hold the total ;; time, total cons, total-calls, and the max time/call. (defun compute-widths (info) (let ((total-time 0) (total-cons 0) (total-calls 0) (max-time/call 0) (max-cons/call 0)) ;; Find the total time, total consing, total calls, and the max ;; time/call (dolist (item info) (let ((time (time-info-time item))) (incf total-time time) (incf total-cons (time-info-consing item)) (incf total-calls (time-info-calls item)) (setf max-time/call (max max-time/call (/ time (float (time-info-calls item))))) (setf max-cons/call (max max-cons/call (/ (time-info-consing item) (float (time-info-calls item))))))) ;; Figure out the width needed for total-time, total-cons, ;; total-calls and the max-time/call. The total-cons is more ;; complicated because we print the consing with comma ;; separators. For total-time, we assume a default of "~10,3F"; ;; for total-calls, "~7D"; for time/call, "~10,5F". This is where ;; the constants come from. (flet ((safe-log10 (x) ;; log base 10 of x, but any non-positive value of x, 0 ;; is ok for what we want. (if (zerop x) 0.0 (log x 10)))) (let ((cons-length (ceiling (safe-log10 total-cons))) (calls-length (ceiling (safe-log10 total-calls))) (cons/call-len (ceiling (safe-log10 max-cons/call)))) ;; Adjust these to include the number of commas that will be ;; printed. (incf cons-length (floor (safe-log10 total-cons) 3)) (incf calls-length (floor (safe-log10 total-calls) 3)) (incf cons/call-len (floor (safe-log10 max-cons/call) 3)) (make-width-info :cons (max 9 cons-length) :calls (max 7 calls-length) :time (+ 4 (ceiling (safe-log10 total-time))) :time/call (+ 6 (max 2 (ceiling (safe-log10 max-time/call)))) :cons/call (max 8 cons/call-len)))))) (defstruct (time-info (:constructor make-time-info (name calls time consing consing-w/c callers))) name calls time consing consing-w/c callers) (defstruct (time-totals) (time 0.0) (consed 0) (calls 0)) (defun report-times-time (time action &optional field-widths) (multiple-value-bind (time-width cons-width calls-width time/call-width cons/call-width) (if field-widths (values (width-info-time field-widths) (width-info-cons field-widths) (width-info-calls field-widths) (width-info-time/call field-widths) (width-info-cons/call field-widths)) (values 9 9 7 10 10)) (case action (:head (format *trace-output* "~&~V@A | ~V@A | ~V@A | ~V@A | ~V@A | Name:~@ -----------------------------------------------------------------------~%" cons-width "Consed" calls-width "Calls" time-width "Secs" time/call-width "Sec/Call" cons/call-width "Bytes/C." ) (return-from report-times-time)) (:tail (format *trace-output* "-------------------------------------------------------------------~@ ~V:D | ~V:D | ~V,3F | ~V:A | ~V:A | Total~%" cons-width (time-totals-consed time) calls-width (time-totals-calls time) time-width (time-totals-time time) time/call-width "" cons/call-width "")) (:sort (sort time #'>= :key #'time-info-time)) (:one-function (format *trace-output* "~V:D | ~V:D | ~V,3F | ~V,5F | ~V:D | ~S~%" cons-width (floor (time-info-consing time)) calls-width (time-info-calls time) time-width (time-info-time time) time/call-width (/ (time-info-time time) (float (time-info-calls time))) cons/call-width (round (/ (time-info-consing time) (float (time-info-calls time)))) (time-info-name time))) (t (error "Unknown action for profiler report: ~s" action))))) (defun report-times-space (time action &optional field-widths) (case action (:head (format *trace-output* "~& Consed w/c | Consed | Calls | Sec/Call | Bytes/C. | Name:~@ -----------------------------------------------------------------------~%") (return-from report-times-space)) (:tail (format *trace-output* "-------------------------------------------------------------------~@ :-) |~11:D |~10:D | | | Total~%" (time-totals-consed time) (time-totals-calls time))) (:sort (sort time #'>= :key #'time-info-consing)) (:one-function (format *trace-output* "~11:D |~11:D |~10:D |~10,5F |~10:D | ~S~%" (floor (time-info-consing-w/c time)) (floor (time-info-consing time)) (time-info-calls time) (/ (time-info-time time) (float (time-info-calls time))) (round (/ (time-info-consing time) (float (time-info-calls time)))) (time-info-name time))) (t (error "Unknown action for profiler report")))) (defparameter *default-report-time-printfunction* #'report-times-time) (defun %report-times (names &key (printfunction *default-report-time-printfunction*)) (declare (optimize (speed 0))) (unless (boundp '*call-overhead*) (compute-time-overhead)) (let ((info ()) (no-call ()) (widths ())) (dolist (name names) (let ((pinfo (pi-or-lose name))) (multiple-value-bind (calls time consing consing-w/c profile callers) (profile-info-profiling-values pinfo) (if (zerop calls) (push name no-call) (push (make-time-info name calls (compensate-time calls time profile) consing consing-w/c (sort (copy-seq callers) #'>= :key #'cdr)) info))))) (setq info (funcall printfunction info :sort)) (setf widths (compute-widths info)) (funcall printfunction nil :head widths) (let ((totals (make-time-totals))) (dolist (time info) (incf (time-totals-time totals) (time-info-time time)) (incf (time-totals-calls totals) (time-info-calls time)) (incf (time-totals-consed totals) (time-info-consing time)) (funcall printfunction time :one-function widths) (let ((callers (time-info-callers time)) (*print-readably* nil)) (when callers (dolist (x (subseq callers 0 (min (length callers) 5))) (format *trace-output* "~13T~10:D: " (cdr x)) (print-caller-info (car x) *trace-output*) (terpri *trace-output*)) (terpri *trace-output*)))) (funcall printfunction totals :tail widths)) (when no-call (setf *no-calls* no-call) (if (and (realp *no-calls-limit*) (>= (length no-call) *no-calls-limit*)) (format *trace-output* "~%~D functions were not called. ~ See profile::*no-calls* for a list~%" (length no-call)) (format *trace-output* "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call #'string< :key (lambda (n) (if (symbolp n) (symbol-name n) (multiple-value-bind (valid block-name) (ext:valid-function-name-p n) (declare (ignore valid)) (if block-name block-name (princ-to-string n))))))))) (values))) (defmacro reset-time (&rest names) "Resets the time counter for the named functions. Names defaults to the list of all currently profiled functions." `(%reset-time ,(if names `',names '*timed-functions*))) (defun %reset-time (names) (dolist (name names) (reset-profile-info (pi-or-lose name))) (values)) (defmacro report-time (&rest names) "Reports the time spent in the named functions. Names defaults to the list of all currently profiled functions." `(%report-times ,(if names `',names '*timed-functions*))) (defun report-time-custom (&key names printfunction) "Reports the time spent in the named functions. Names defaults to the list of all currently profiled functions. Uses printfunction." (%report-times (or names *timed-functions*) :printfunction (or (typecase printfunction (null *default-report-time-printfunction*) (function printfunction) (symbol (case printfunction (:space #'report-times-space) (:time #'report-times-time)))) (error "Cannot handle printfunction ~s" printfunction)))) ;;;; Overhead computation. ;;; We average the timing overhead over this many iterations. ;;; (defconstant timer-overhead-iterations 5000) ;;; COMPUTE-TIME-OVERHEAD-AUX -- Internal ;;; ;;; Dummy function we profile to find profiling overhead. Declare ;;; debug-info to make sure we have arglist info. ;;; (declaim (notinline compute-time-overhead-aux)) (defun compute-time-overhead-aux (x) (declare (ext:optimize-interface (debug 2))) (declare (ignore x))) ;;; COMPUTE-TIME-OVERHEAD -- Internal ;;; ;;; Initialize the profiling overhead variables. ;;; (defun compute-time-overhead () (macrolet ((frob (var) `(let ((start (quickly-get-time)) (fun (symbol-function 'compute-time-overhead-aux))) (dotimes (i timer-overhead-iterations) (funcall fun fun)) (setq ,var (/ (float (- (quickly-get-time) start)) (float quick-time-units-per-second) (float timer-overhead-iterations)))))) (frob *call-overhead*) (unwind-protect (progn (profile compute-time-overhead-aux) (frob *total-profile-overhead*) (decf *total-profile-overhead* *call-overhead*) (let ((pinfo (pi-or-lose 'compute-time-overhead-aux))) (multiple-value-bind (calls time) (profile-info-profiling-values pinfo) (declare (ignore calls)) (setq *internal-profile-overhead* (/ (float time) (float quick-time-units-per-second) (float timer-overhead-iterations)))))) (unprofile compute-time-overhead-aux)))) (pushnew (lambda () (makunbound '*call-overhead*)) ext:*before-save-initializations*) ;;; ;;; (with-spacereport ...) and friends ;;; ;;; TODO: ;;; - if counting place haven't been allocated at compile time, try to do it ;;; at load time ;;; - Introduce a mechanism that detects whether *all* calls were the same ;;; amount of bytes (single variable). ;;; - record the source file and place this report appears in ;;; - detect whether this is a nested spacereport and if so, record ;;; the outer reports ;; This struct is used for whatever counting the checkpoints do ;; AND ;; stores information we find at compile time (defstruct spacereport-info (n 0 :type fixnum) (consed-h 0 :type dfixnum:dfparttype) (consed-l 0 :type dfixnum:dfparttype) (codesize -1 :type fixnum)) ;; In the usual case, the hashtable with entries will be allocated at ;; compile or load time (eval-when (load eval) (defvar *spacereports* (make-hash-table))) ;; ;; Helper functions ;; (defun format-quotient (p1 p2 width komma) (let (format) (cond ((= 0 p2) (make-string width :initial-element #\ )) ((and (integerp p1) (integerp p2) (zerop (rem p1 p2))) (setf format (format nil "~~~d:D!~a" (- width komma 1) (make-string komma :initial-element #\ ))) (format nil format (/ p1 p2))) (t (setf format (format nil "~~~d,~df" width komma)) (format nil format (/ (float p1) (float p2))))))) (defun deep-list-length (list) (let ((length 0)) (dolist (e list) (when (listp e) (incf length (deep-list-length e))) (incf length)) length)) ;; bunch for tests for above #+nil (defun test-format-quotient () (print (format-quotient 10 5 10 2)) (print (format-quotient 10 3 10 2)) (print (format-quotient 10 5 10 0)) (print (format-quotient 10 3 10 0)) (print (format-quotient 10 0 10 0))) (defvar *insert-spacereports* t) ;; Main wrapper macro for user - exported (defmacro with-spacereport (name-or-args &body body) (if (not *insert-spacereports*) `(progn ,@body) (let ((name (typecase name-or-args (symbol name-or-args) (cons (first name-or-args)) (t (error "Spacereport args neither symbol nor cons") nil))) (options (if (consp name-or-args) (rest name-or-args) nil))) (when (gethash name *spacereports*) (unless (find :mok options) (warn "spacereport for ~a was requested before, resetting it" name))) (setf (gethash name *spacereports*) (make-spacereport-info)) (setf (spacereport-info-codesize (gethash name *spacereports*)) (deep-list-length body)) `(let* ((counterplace nil) (place (gethash ,name *spacereports*)) (start-h 0) (start-l 0)) (declare (type dfixnum:dfparttype start-h start-l)) (declare (type (or dfixnum:dfixnum null) counterplace)) (declare (type (or spacereport-info null) place)) ;; Make sure counter is there (unless place ;; Ups, it isn't, so create it... (setf place (make-spacereport-info)) (setf (gethash ,name *spacereports*) place) (print "with-spaceprofile had to create place, leaked bytes to outer spacereports in nested calls")) ;; Remember bytes already consed at start (setf counterplace (total-consing)) (dfixnum:dfixnum-set-pair start-h start-l counterplace) (prog1 (progn ,@body) (incf (spacereport-info-n place)) ;; Add bytes newly consed. ;; first update counterplace. (total-consing) (dfixnum:dfixnum-inc-pair (spacereport-info-consed-h place) (spacereport-info-consed-l place) (dfixnum::dfixnum-h counterplace) (dfixnum::dfixnum-l counterplace)) (dfixnum:dfixnum-dec-pair (spacereport-info-consed-h place) (spacereport-info-consed-l place) start-h start-l)))))) (defun print-spacereports (&optional (stream *trace-output*)) (maphash (lambda (key value) (format stream "~&~10:D bytes ~9:D calls ~a b/call: ~a (sz ~d)~%" (dfixnum:dfixnum-pair-integer (spacereport-info-consed-h value) (spacereport-info-consed-l value)) (spacereport-info-n value) (format-quotient (dfixnum:dfixnum-pair-integer (spacereport-info-consed-h value) (spacereport-info-consed-l value)) (spacereport-info-n value) 10 2) key (spacereport-info-codesize value))) *spacereports*)) (defun reset-spacereports () (maphash (lambda (key value) (declare (ignore key)) (setf (spacereport-info-consed-h value) 0) (setf (spacereport-info-consed-l value) 0) (setf (spacereport-info-n value) 0)) *spacereports*)) (defun delete-spacereports () (maphash (lambda (key value) (declare (ignore value)) (remhash key *spacereports*)) *spacereports*)) cmucl-21a/src/code/purify.lisp000066400000000000000000000051561260377556400165000ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/purify.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Storage purifier for Spice Lisp. ;;; Written by Rob MacLachlan and Skef Wholey. ;;; ;;; Rewritten in C by William Lott. ;;; (in-package "LISP") (intl:textdomain "cmucl") (export 'ext::purify "EXT") (alien:def-alien-routine ("purify" %purify) c-call:void (static-roots c-call:unsigned-long) (read-only-roots c-call:unsigned-long)) ;;; COMPACT-ENVIRONMENT-AUX -- Internal ;;; ;;; Compact the info environment. Written with gratuitous recursion to ;;; make sure that our (and compact-info-environment's) local variables are ;;; above the stack top when purify runs. ;;; (defun compact-environment-aux (name n) (cond ((zerop n) (let ((old-ie (car *info-environment*))) (setq *info-environment* (list* (make-info-environment :name "Working") (compact-info-environment (first *info-environment*) :name name) (rest *info-environment*))) (shrink-vector (c::volatile-info-env-table old-ie) 0))) (t (compact-environment-aux name (1- n)) n))) (defun purify (&key root-structures (environment-name "Auxiliary")) "This function optimizes garbage collection by moving all currently live objects into non-collected storage. ROOT-STRUCTURES is an optional list of objects which should be copied first to maximize locality. DEFSTRUCT structures defined with the (:PURE T) option are moved into read-only storage, further reducing GC cost. List and vector slots of pure structures are also moved into read-only storage. ENVIRONMENT-NAME is gratuitous documentation for compacted version of the current global environment (as seen in C::*INFO-ENVIRONMENT*.) If NIL is supplied, then environment compaction is inhibited." (when environment-name (compact-environment-aux environment-name 200)) (let ((*gc-notify-before* #'(lambda (bytes-in-use) (declare (ignore bytes-in-use)) (write-string (intl:gettext "[Doing purification: ")) (force-output))) (*internal-gc* #'(lambda () (%purify (get-lisp-obj-address root-structures) (get-lisp-obj-address nil)))) (*gc-notify-after* #'(lambda (&rest ignore) (declare (ignore ignore)) (write-line (intl:gettext "Done.]"))))) #-gencgc (gc t) #+gencgc (gc :verbose t)) nil) cmucl-21a/src/code/query.lisp000066400000000000000000000051341260377556400163230ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/query.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Querying the user. ;;; Written by Walter van Roggen, 27 December 1982. ;;; Brought up to date and fixed somewhat by Rob MacLachlan. ;;; Modified by Bill Chiles. ;;; ;;; These functions are part of the standard Spice Lisp environment. ;;; ;;; ********************************************************************** ;;; (in-package "LISP") (intl:textdomain "cmucl") (export '(y-or-n-p yes-or-no-p)) (defun query-readline () (force-output *query-io*) (string-trim " " (read-line *query-io*))) ;;; Y-OR-N-P -- Public. ;;; (defun y-or-n-p (&optional format-string &rest arguments) "Y-OR-N-P prints the message, if any, and reads characters from *QUERY-IO* until the user enters y or Y as an affirmative, or either n or N as a negative answer. It ignores preceding whitespace and asks again if you enter any other characters." (when format-string (fresh-line *query-io*) (apply #'format *query-io* format-string arguments)) (loop (let* ((line (query-readline)) (ans (if (string= line "") #\? ;Force CASE below to issue instruction. (schar line 0)))) (unless (whitespacep ans) (case ans ((#\y #\Y) (return t)) ((#\n #\N) (return nil)) (t (write-line (intl:gettext "Type \"y\" for yes or \"n\" for no. ") *query-io*) (when format-string (apply #'format *query-io* format-string arguments)) (force-output *query-io*))))))) ;;; YES-OR-NO-P -- Public. ;;; ;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and ;;; uses READ-LINE to get "YES" or "NO". ;;; (defun yes-or-no-p (&optional format-string &rest arguments) "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the input buffer, beeps, and uses READ-LINE to get the strings YES or NO." (clear-input *query-io*) (beep) (when format-string (fresh-line *query-io*) (apply #'format *query-io* format-string arguments)) (do ((ans (query-readline) (query-readline))) (()) (cond ((string-equal ans "YES") (return t)) ((string-equal ans "NO") (return nil)) (t (write-line (intl:gettext "Type \"yes\" for yes or \"no\" for no. ") *query-io*) (when format-string (apply #'format *query-io* format-string arguments)))))) cmucl-21a/src/code/rand-mt19937.lisp000066400000000000000000000366231260377556400171440ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Kernel -*- ;;; ;;; ********************************************************************** ;;; This code was written by Douglas T. Crosher and Raymond Toy based ;;; on public domain code from Carnegie Mellon University and has been ;;; placed in the Public domain, and is provided 'as is'. ;;; (ext:file-comment "$Header: src/code/rand-mt19937.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Support for the Mersenne Twister, MT19937, random number generator ;;; due to Matsumoto and Nishimura. This implementation has been ;;; placed in the public domain with permission from M. Matsumoto. ;;; ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A ;;; 623-dimensionally equidistributed uniform pseudorandom number ;;; generator.", ACM Transactions on Modeling and Computer Simulation, ;;; 1997, to appear. (in-package "LISP") (intl:textdomain "cmucl") (export '(random-state random-state-p random *random-state* make-random-state)) (in-package "KERNEL") (export '(%random-single-float %random-double-float random-chunk init-random-state)) (sys:register-lisp-feature :random-mt19937) ;;;; Random state hackery: ;;; The state is stored in a (simple-array (unsigned-byte 32) (627)) ;;; wrapped in a random-state structure: ;;; ;;; 0-1: Constant matrix A. [0, #x9908b0df] ;;; 2: Index k. ;;; 3-626: State. ;; GENERATE-SEED ;; ;; Generate a random seed that can be used for seeding the generator. ;; If /dev/urandom is available, it is used to generate random data as ;; the seed. Otherwise, the current time is used as the seed. ;; ;; The /dev/urandom device exists on Linux, FreeBSD, Solaris 8 and ;; later. (You need to have patch 112438-01 for Solaris 8 to get that ;; device, though). It returns pseudorandom data with entropy that the ;; kernel collects from the environment. Unlike the related ;; /dev/random, this device does not block when the entropy pool has ;; been depleted. (defun generate-seed (&optional (nwords 1)) ;; On some systems (as reported by Ole Rohne on cmucl-imp), ;; /dev/urandom isn't what we think it is, so if it doesn't work, ;; silently generate the seed from the current time. (or (ignore-errors (let ((words (make-array nwords :element-type '(unsigned-byte 32)))) (with-open-file (rand "/dev/urandom" :direction :input :element-type '(unsigned-byte 32)) (read-sequence words rand)) (if (= nwords 1) (aref words 0) words))) (logand (get-universal-time) #xffffffff))) ;; New initializer proposed by Takuji Nishimura and Makota Matsumoto. ;; (See http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/emt19937ar.html) ;; ;; This corrects a deficiency in the original initializer wherein the ;; MSB of the seed was not well represented in the state. ;; ;; The initialization routine is described below. Let s be the seed, ;; mt[] be the state vector. Then the algorithm is ;; ;; mt[0] = s & 0xffffffffUL ;; ;; for (k = 1; k < N; k++) { ;; mt[k] = 1812433253 * (mt[k-1] ^ (mt[k-1] >> 30)) + k ;; mt[k] &= 0xffffffffUL ;; } ;; ;; The multiplier is from Knuth TAOCP Vol2, 3rd Ed., p. 106. ;; (defun int-init-random-state (&optional (seed 5489) state) (declare (type (integer 0 #xffffffff) seed)) (let ((state (or state (make-array 627 :element-type '(unsigned-byte 32))))) (declare (type (simple-array (unsigned-byte 32) (627)) state)) (setf (aref state 0) 0) (setf (aref state 1) #x9908b0df) (setf (aref state 2) mt19937-n) (setf (aref state 3) seed) (do ((k 1 (1+ k))) ((>= k 624)) (declare (type (mod 625) k)) (let ((prev (aref state (+ 3 (1- k))))) (setf (aref state (+ 3 k)) (logand (+ (* 1812433253 (logxor prev (ash prev -30))) k) #xffffffff)))) state)) ;; Initialize from an array. ;; ;; Here is the algorithm, in C. init_genrand is the initalizer above, ;; init_key is the seed vector of length key_length. ;; ;; init_genrand(19650218UL); ;; i=1; j=0; ;; k = (N>key_length ? N : key_length); ;; for (; k; k--) { ;; mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525UL)) ;; + init_key[j] + j; /* non linear */ ;; mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */ ;; i++; j++; ;; if (i>=N) { ;; mt[0] = mt[N-1]; i=1; ;; } ;; if (j>=key_length) { ;; j=0; ;; } ;; } ;; for (k=N-1; k; k--) { ;; mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941UL)) ;; - i; /* non linear */ ;; mt[i] &= 0xffffffffUL; /* for WORDSIZE > 32 machines */ ;; i++; ;; if (i>=N) { mt[0] = mt[N-1]; i=1; } ;; } ;; ;; mt[0] = 0x80000000UL; /* MSB is 1; assuring non-zero initial array */ ;; (defun vec-init-random-state (key &optional state) (declare (type (array (unsigned-byte 32) (*)) key)) (let ((key-len (length key)) (state (init-random-state 19650218 state)) (i 1) (j 0)) (loop for k from (max key-len mt19937-n) above 0 do (let ((prev (aref state (+ 3 (1- i))))) (setf (aref state (+ 3 i)) (ldb (byte 32 0) (+ (aref key j) j (logxor (aref state (+ 3 i)) (ldb (byte 32 0) (* 1664525 (logxor prev (ash prev -30)))))))) (incf i) (incf j) (when (>= i mt19937-n) (setf (aref state 3) (aref state (+ 3 (- mt19937-n 1)))) (setf i 1)) (when (>= j key-len) (setf j 0)))) (loop for k from (1- mt19937-n) above 0 do (let ((prev (aref state (+ 3 (1- i))))) (setf (aref state (+ 3 i)) (ldb (byte 32 0) (- (logxor (aref state (+ 3 i)) (* 1566083941 (logxor prev (ash prev -30)))) i))) (incf i) (when (>= i mt19937-n) (setf (aref state 3) (aref state (+ 3 (- mt19937-n 1)))) (setf i 1)))) (setf (aref state 3) #x80000000) state)) ;; (defun init-random-state (&optional (seed 5489) state) "Generate an random state vector from the given SEED. The seed can be either an integer or a vector of (unsigned-byte 32)" (declare (type (or null integer (array (unsigned-byte 32) (*))) seed)) (etypecase seed (integer (int-init-random-state (ldb (byte 32 0) seed) state)) ((array (unsigned-byte 32) (*)) (vec-init-random-state seed state)))) (defstruct (random-state (:constructor make-random-object) (:make-load-form-fun :just-dump-it-normally)) (state (init-random-state) :type (simple-array (unsigned-byte 32) (627)))) (defvar *random-state* (make-random-object)) (defun make-random-state (&optional state) "Make a random state object. If STATE is not supplied, return a copy of the default random state. If STATE is a random state, then return a copy of it. If STATE is T then return a random state generated from the universal time or /dev/urandom if available." (flet ((copy-random-state (state) (let ((state (random-state-state state)) (new-state (make-array 627 :element-type '(unsigned-byte 32)))) (dotimes (i 627) (setf (aref new-state i) (aref state i))) (make-random-object :state new-state)))) (cond ((not state) (copy-random-state *random-state*)) ((random-state-p state) (copy-random-state state)) ((eq state t) (make-random-object :state (init-random-state (generate-seed 627)))) (t (error (intl:gettext "Argument is not a RANDOM-STATE, T or NIL: ~S") state))))) (defun rand-mt19937-initializer () (init-random-state (generate-seed) (random-state-state *random-state*))) (pushnew 'rand-mt19937-initializer ext:*after-save-initializations*) ;;;; Random entries: ;;; Size of the chunks returned by random-chunk. ;;; (defconstant random-chunk-length 32) ;;; random-chunk -- Internal ;;; ;;; This function generaters a 32bit integer between 0 and #xffffffff ;;; inclusive. ;;; (declaim (inline random-chunk)) ;;; ;;; Portable implementation. (defconstant mt19937-n 624) (defconstant mt19937-m 397) (defconstant mt19937-upper-mask #x80000000) (defconstant mt19937-lower-mask #x7fffffff) (defconstant mt19937-b #x9D2C5680) (defconstant mt19937-c #xEFC60000) ;;; #-x86 (defun random-mt19937-update (state) (declare (type (simple-array (unsigned-byte 32) (627)) state) (optimize (speed 3) (safety 0))) (let ((y 0)) (declare (type (unsigned-byte 32) y)) (do ((kk 3 (1+ kk))) ((>= kk (+ 3 (- mt19937-n mt19937-m)))) (declare (type (mod 628) kk)) (setf y (logior (logand (aref state kk) mt19937-upper-mask) (logand (aref state (1+ kk)) mt19937-lower-mask))) (setf (aref state kk) (logxor (aref state (+ kk mt19937-m)) (ash y -1) (aref state (logand y 1))))) (do ((kk (+ (- mt19937-n mt19937-m) 3) (1+ kk))) ((>= kk (+ (1- mt19937-n) 3))) (declare (type (mod 628) kk)) (setf y (logior (logand (aref state kk) mt19937-upper-mask) (logand (aref state (1+ kk)) mt19937-lower-mask))) (setf (aref state kk) (logxor (aref state (+ kk (- mt19937-m mt19937-n))) (ash y -1) (aref state (logand y 1))))) (setf y (logior (logand (aref state (+ 3 (1- mt19937-n))) mt19937-upper-mask) (logand (aref state 3) mt19937-lower-mask))) (setf (aref state (+ 3 (1- mt19937-n))) (logxor (aref state (+ 3 (1- mt19937-m))) (ash y -1) (aref state (logand y 1))))) (values)) ;;; #-x86 (defun random-chunk (state) (declare (type random-state state) (optimize (speed 3) (safety 0))) (let* ((state (random-state-state state)) (k (aref state 2))) (declare (type (mod 628) k)) (when (= k mt19937-n) (random-mt19937-update state) (setf k 0)) (setf (aref state 2) (1+ k)) (let ((y (aref state (+ 3 k)))) (declare (type (unsigned-byte 32) y)) (setf y (logxor y (ash y -11))) (setf y (logxor y (ash (logand y (ash mt19937-b -7)) 7))) (setf y (logxor y (ash (logand y (ash mt19937-c -15)) 15))) (setf y (logxor y (ash y -18))) y))) ;;; Using inline VOP support, only available on the x86 so far. #+x86 (defun random-chunk (state) (declare (type random-state state)) (vm::random-mt19937 (random-state-state state))) ;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface ;;; ;;; Handle the single or double float case of RANDOM. We generate a float ;;; between 0.0 and 1.0 by clobbering the significand of 1.0 with random bits, ;;; then subtracting 1.0. This hides the fact that we have a hidden bit. ;;; (declaim (inline %random-single-float %random-double-float)) (declaim (ftype (function ((single-float (0f0)) random-state) (single-float 0f0)) %random-single-float)) ;;; (defun %random-single-float (arg state) (declare (type (single-float (0f0)) arg) (type random-state state)) (* arg (- (make-single-float (dpb (ash (random-chunk state) (- vm:single-float-digits random-chunk-length)) vm:single-float-significand-byte (single-float-bits 1.0))) 1.0))) ;;; (declaim (ftype (function ((double-float (0d0)) random-state) (double-float 0d0)) %random-double-float)) ;;; ;;; 32bit version ;;; #+nil (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) (type random-state state)) (* (float (random-chunk state) 1d0) (/ 1d0 (expt 2 32)))) ;;; ;;; 53bit version. ;;; #-x86 (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) (type random-state state)) (* arg (- (lisp::make-double-float (dpb (ash (random-chunk state) (- vm:double-float-digits random-chunk-length vm:word-bits)) vm:double-float-significand-byte (lisp::double-float-high-bits 1d0)) (random-chunk state)) 1d0))) ;;; Using a faster inline VOP. #+x86 (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) (type random-state state)) (let ((state-vector (random-state-state state))) (* arg (- (lisp::make-double-float (dpb (ash (vm::random-mt19937 state-vector) (- vm:double-float-digits random-chunk-length vm:word-bits)) vm:double-float-significand-byte (lisp::double-float-high-bits 1d0)) (vm::random-mt19937 state-vector)) 1d0)))) #+long-float (declaim (inline %random-long-float)) #+long-float (declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0)) %random-long-float)) ;;; Using a faster inline VOP. #+(and long-float x86) (defun %random-long-float (arg state) (declare (type (long-float (0l0)) arg) (type random-state state)) (let ((state-vector (random-state-state state))) (* arg (- (lisp::make-long-float (lisp::long-float-exp-bits 1l0) (logior (vm::random-mt19937 state-vector) vm:long-float-hidden-bit) (vm::random-mt19937 state-vector)) 1l0)))) #+(and long-float sparc) (defun %random-long-float (arg state) (declare (type (long-float (0l0)) arg) (type random-state state)) (* arg (- (lisp::make-long-float (lisp::long-float-exp-bits 1l0) ; X needs more work (random-chunk state) (random-chunk state) (random-chunk state)) 1l0))) #+double-double (defun %random-double-double-float (arg state) (declare (type (double-double-float (0w0)) arg) (type random-state state)) ;; Generate a 31-bit integer, scale it and sum them up (let* ((r 0w0) (scale (scale-float 1d0 -31)) (mult scale)) (declare (double-float mult) (type double-double-float r) (optimize (speed 3) (inhibit-warnings 3))) (dotimes (k 4) (setf r (+ r (* mult (ldb (byte 31 0) (random-chunk state))))) (setf mult (* mult scale))) (* arg r))) ;;;; Random integers: ;;; Amount we overlap chunks by when building a large integer to make up for ;;; the loss of randomness in the low bits. ;;; (defconstant random-integer-overlap 3) ;;; Extra bits of randomness that we generate before taking the value MOD the ;;; limit, to avoid loss of randomness near the limit. ;;; (defconstant random-integer-extra-bits 10) ;;; Largest fixnum we can compute from one chunk of bits. ;;; (defconstant random-fixnum-max (1- (ash 1 (- random-chunk-length random-integer-extra-bits)))) ;;; %RANDOM-INTEGER -- Internal ;;; (defun %random-integer (arg state) (declare (type (integer 1) arg) (type random-state state)) (let ((shift (- random-chunk-length random-integer-overlap))) (do ((bits (random-chunk state) (logxor (ash bits shift) (random-chunk state))) (count (+ (integer-length arg) (- random-integer-extra-bits shift)) (- count shift))) ((minusp count) (rem bits arg)) (declare (fixnum count))))) (defun random (arg &optional (state *random-state*)) "Generate a uniformly distributed pseudo-random number between zero and Arg. State, if supplied, is the random state to use." (declare (inline %random-single-float %random-double-float #+long-float %long-float)) (cond ((typep arg '(integer 1 #x100000000)) ;; Let the compiler deftransform take care of this case. (random arg state)) ((and (typep arg 'single-float) (> arg 0.0F0)) (%random-single-float arg state)) ((and (typep arg 'double-float) (> arg 0.0D0)) (%random-double-float arg state)) #+long-float ((and (typep arg 'long-float) (> arg 0.0L0)) (%random-long-float arg state)) #+double-double ((and (typep arg 'double-double-float) (> arg 0.0w0)) (%random-double-double-float arg state)) ((and (integerp arg) (> arg 0)) (%random-integer arg state)) (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0.0))) :datum arg :format-control (intl:gettext "Argument is not a positive integer or a positive float: ~S") :format-arguments (list arg))))) cmucl-21a/src/code/rand.lisp000066400000000000000000000444141260377556400161060ustar00rootroot00000000000000;;; -*- Mode: Lisp; Package: Kernel -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/rand.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Functions to random number functions for Spice Lisp ;;; ;;; Originally written by David Adam. Python tuning, better large integer ;;; randomness and efficient IEEE float support by Rob MacLachlan. ;;; #-new-random (in-package "LISP") (intl:textdomain "cmucl") #-new-random (export '(random-state random-state-p random *random-state* make-random-state)) #-new-random (in-package "KERNEL") #-new-random (export '(%random-single-float %random-double-float random-chunk random-fixnum-max)) ;;;; Random state hackery: #-new-random (progn (defconstant random-const-a 8373) (defconstant random-const-c 101010101) (defconstant random-max 54) ;;; Inclusive upper bound on the size of fixnum kept in the state (and returned ;;; by random-chunk.) Must be even. ;;; (defconstant random-upper-bound (- most-positive-fixnum 3)) (defconstant random-chunk-length (integer-length random-upper-bound)) (deftype random-chunk () `(integer 0 ,random-upper-bound)) (defvar rand-seed 0) (defstruct (random-state (:constructor make-random-object) (:make-load-form-fun :just-dump-it-normally)) (j 24 :type index) (k 0 :type index) (seed (make-array (1+ random-max) :initial-contents (do ((list-rands () (cons (rand1) list-rands)) (i 0 (1+ i))) ((> i random-max) list-rands) (declare (fixnum i)))) :type simple-vector)) ;;; Generates a random number from rand-seed. (defun rand1 () (declare (optimize (inhibit-warnings 3))) (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c) (1+ random-upper-bound)))) (defvar *random-state* (make-random-object)) (defun copy-state (cur-state) (let ((state (make-random-object :seed (make-array 55) :j (random-state-j cur-state) :k (random-state-k cur-state)))) (do ((i 0 (1+ i))) ((= i 55) state) (declare (fixnum i)) (setf (aref (random-state-seed state) i) (aref (random-state-seed cur-state) i))))) (defun make-random-state (&optional state) "Make a random state object. If State is not supplied, return a copy of the default random state. If State is a random state, then return a copy of it. If state is T then return a random state generated from the universal time." (cond ((not state) (copy-state *random-state*)) ((random-state-p state) (copy-state state)) ((eq state t) (setq rand-seed (get-universal-time)) (make-random-object)) (t (error 'simple-type-error :expected-type '(or null t (satisfies random-state-p)) :datum state :format-control "Argument is not a RANDOM-STATE, T or NIL: ~S" :format-arguments (list state))))) ;;;; Random entries: (declaim (start-block random %random-single-float %random-double-float random-chunk)) ;;; random-chunk -- Internal ;;; ;;; This function generates fixnums between 0 and random-upper-bound, ;;; inclusive. For the algorithm to work random-upper-bound must be an ;;; even positive fixnum. State is the random state to use. ;;; (declaim (ftype (function (random-state) random-chunk) random-chunk)) (defun random-chunk (state) (let* ((seed (random-state-seed state)) (j (random-state-j state)) (k (random-state-k state)) (a (- (- random-upper-bound (the random-chunk (svref seed (setf (random-state-j state) (if (= j 0) random-max (1- j)))))) (the random-chunk (svref seed (setf (random-state-k state) (if (= k 0) random-max (1- k)))))))) (declare (fixnum a)) (setf (svref seed k) (the random-chunk (if (minusp a) (- a) (- random-upper-bound a)))))) ;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface ;;; ;;; Handle the single or double float case of RANDOM. We generate a float ;;; between 0.0 and 1.0 by clobbering the significand of 1.0 with random bits, ;;; then subtracting 1.0. This hides the fact that we have a hidden bit. ;;; (declaim (inline %random-single-float %random-double-float)) (defun %random-single-float (arg state) (declare (type (single-float (0f0)) arg) (type (or random-state null) state)) (* arg (- (make-single-float (dpb (ash (random-chunk (or state *random-state*)) (- vm:single-float-digits random-chunk-length)) vm:single-float-significand-byte (single-float-bits 1.0))) 1.0))) ;;; (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) (type (or random-state null) state)) (let ((state (or state *random-state*))) (* arg (- (make-double-float (dpb (ash (random-chunk state) (- vm:double-float-digits random-chunk-length vm:word-bits)) vm:double-float-significand-byte (double-float-high-bits 1d0)) (logxor (ash (random-chunk state) (- vm:word-bits random-chunk-length)) (ash (random-chunk state) (- random-chunk-length vm:word-bits)))) 1d0)))) ;;;; Random integers: ;;; Amount we overlap chunks by when building a large integer to make up for ;;; the loss of randomness in the low bits. ;;; (defconstant random-integer-overlap 3) ;;; Extra bits of randomness that we generate before taking the value MOD the ;;; limit, to avoid loss of randomness near the limit. ;;; (defconstant random-integer-extra-bits 10) ;;; Largest fixnum we can compute from one chunk of bits. ;;; (defconstant random-fixnum-max (1- (ash 1 (- random-chunk-length random-integer-extra-bits)))) ;;; %RANDOM-INTEGER -- Internal ;;; (defun %random-integer (arg state) (declare (type (integer 1) arg) (type random-state state)) (let ((shift (- random-chunk-length random-integer-overlap))) (do ((bits (random-chunk state) (logxor (ash bits shift) (random-chunk state))) (count (+ (integer-length arg) (- random-integer-extra-bits shift)) (- count shift))) ((minusp count) (rem bits arg)) (declare (fixnum count))))) (defun random (arg &optional (state *random-state*)) "Generate a uniformly distributed pseudo-random number between zero and Arg. State, if supplied, is the random state to use." (declare (inline %random-single-float %random-double-float)) (cond ((and (fixnump arg) (<= arg random-fixnum-max)) (rem (random-chunk state) arg)) ((typep arg 'single-float) (%random-single-float arg state)) ((typep arg 'double-float) (%random-double-float arg state)) ((integerp arg) (%random-integer arg state)) (t (error 'simple-type-error :expected-type '(real (0)) :datum arg :format-control "Argument is not a positive real number: ~S" :format-arguments (list arg))))) ) ; end progn ;;; ;;; ********************************************************************** ;;; ;;; Functions for generating random numbers for CMU Common Lisp. ;;; ;;; Written by Raymond Toy. This is a replacement of the original ;;; rand.lisp in CMUCL. According to tests done by Peter VanEynde, ;;; the original generator fails some tests of randomness in ;;; Marsaglia's diehard test suite. This generator passes those ;;; tests. ;;; ;;; Also, the original generator lacks documentation. This remedies ;;; that, and includes references for the algorithms used. Hopefully ;;; better algorithms have been chosen that are at least as good and ;;; at least as fast as the original. In fact, the heart of the ;;; generator is geared towards generating floating point numbers ;;; which should be faster than the original. This should also give ;;; faster integer numbers since longer floating-point random numbers ;;; are generated. Tests have shown that this new generator is always ;;; a 10-20% faster and upto 3 times faster for double-floats. ;;; #+new-random (in-package "LISP") #+new-random (export '(random-state random-state-p random *random-state* make-random-state)) #+new-random (in-package "KERNEL") #+new-random (export '(%random-single-float %random-double-float)) #+new-random (progn ;;;; Random state hackery used to initialize the random state (defvar rand-seed 54217137) (declaim (type (integer 0 900000000) rand-seed)) ;;; This is the function RMARIN, in James' paper. The routine is ;;; slightly extended to handle the longer floats that we are using ;;; here. (defun init-random-state () (flet ((init-aux (y0 y1 y2 z0) (declare (type (mod 179) y0 y1 y2) (type (mod 169) z0)) (let ((r (make-array 32 :element-type 'double-float))) (dotimes (n 32 r) (declare (fixnum n)) (let ((s 0d0) (tt 0.5d0)) (declare (double-float s tt)) (dotimes (m #.(float-digits 1d0)) (declare (fixnum m)) (let ((new-y (mod (* y0 y1 y2) 179)) (new-z (mod (+ 1 (* 53 z0)) 169))) (when (> (mod (* new-y new-z) 63) 32) (incf s tt)) (setf tt (* tt 0.5d0)) (setf y0 y1) (setf y1 y2) (setf y2 new-y) (setf z0 new-z))) (setf (aref r n) s)))))) (multiple-value-bind (ij kl) (floor rand-seed 30082) (declare (type (integer 0 29918) ij) (type (integer 0 30081) kl)) (multiple-value-bind (i j) (floor ij 177) (declare (type (mod 179) i j)) (incf i 2) (incf j 2) (multiple-value-bind (k L) (floor kl 169) (declare (fixnum k L)) (incf k 1) (init-aux i j k l)))))) (defstruct (random-state (:constructor make-random-object) (:make-load-form-fun :just-dump-it-normally)) (index 0 :type (mod 32)) (weyl 0.0d0 :type double-float) (cache (make-array 32 :element-type 'double-float :initial-contents (init-random-state)) :type (simple-array double-float (32))) (borrow 0.0d0 :type double-float)) (defvar *random-state* (make-random-object)) (defun copy-state (cur-state) (let ((state (make-random-object :index (random-state-index cur-state) :weyl (random-state-weyl cur-state) :borrow (random-state-borrow cur-state) :cache (make-array 32 :element-type 'double-float)))) (dotimes (k 32 state) (declare (fixnum k)) (setf (aref (random-state-cache state) k) (aref (random-state-cache cur-state) k))))) (defun make-random-state (&optional state) "Make a random state object. If State is not supplied, return a copy of the default random state. If State is a random state, then return a copy of it. If state is T then return a random state generated from the universal time." (cond ((not state) (copy-state *random-state*)) ((random-state-p state) (copy-state state)) ((eq state t) (setq rand-seed (mod (get-universal-time) 900000000)) (make-random-object)) (t (error 'simple-type-error :expected-type '(or null t (satisfies random-state-p)) :datum state :format-control "Argument is not a RANDOM-STATE, T or NIL: ~S" :format-arguments (list state))))) ;;;; Random entries #+nil ; Not yet as block compiling tickles compiler trouble. (declaim (start-block random %random-single-float %random-double-float new-random-float)) ;;; random-float -- Internal ;;; ;;; Generates a double-float random number between 0 and 1. ;;; ;;; The technique used is a subtract-with-borrow generator combined ;;; with a Weyl generator. ;;; ;;; The subtract-with-borrow generator is described in the Matlab News ;;; and Notes, Fall 1995, based on suggestions from George ;;; Marsaglia[1]. The generator works as follows. ;;; ;;; The i'th random number is given by ;;; ;;; z[i] = z[i + 20] - z[i + 5] - b ;;; ;;; The indices, i, i + 20, and i + 5 are all interpreted mod 32, ;;; i.e., use just the 5 least significant bits. (Note that we really ;;; only need the last 20 values of z, not the last 32. However, ;;; masking out 5 bits should be faster than comparing against 20.) ;;; ;;; The quantity b is carried over from the previous iteration and is ;;; either 0 or a small quantity. If z[i] is positive, b is set to ;;; zero. If z[i] is negative, we make it positive by adding 1 and we ;;; set b to be 2^-53, or double-float-epsilon for double precision ;;; IEEE floats. ;;; ;;; This generator is claimed to have a period of almost 2^1430 ;;; values. However, it has a defect: all numbers are integer ;;; multiples of 2^-53. Consequently many of the floating-point ;;; numbers are not represented. ;;; ;;; The article describes one method for overcoming this difficulty, ;;; but does not give the full details. Therefore, we use the ;;; technique of combining two generators. The basic idea is to ;;; combine the output from the subtract-with-borrow generator above ;;; with the Weyl generator: x[i] = x[i-1] - y mod 1, where y is any ;;; (fixed) irrational number. This technique is used in RANMAR [2] ;;; and ACARRYPC [3]. ;;; ;;; In RANMAR, y = 7654321 / 2^24. In ACARRYPC, y = 632436069 / 2^32 ;;; is used. We use y = 7097293079245107 / 2^53, where y was randomly ;;; selected. ;;; ;;; Thus, the random number returned is (z[i] - x[i]) mod 1. ;;; ;;; While we could have used a Lisp version of RANMAR, we choose not ;;; to because it only produces single-float results. The generator ;;; given in Matlab News and Notes generates double-float results and ;;; only requires about 32 double-floats of state compared to 97 ;;; single-floats for RANMAR. James also gives a subtract-with-borrow ;;; generator, but it is also only for single-floats. ;;; ;;; Marsaglia's ACARRYPC (below), generates 32-bit integers. ;;; ;;; This generator uses Matlab's generator combined with the technique ;;; given by Marsaglia for combining a Weyl generator with the ;;; subtract-with-borrow generator. This idea also seems to be used ;;; in RANMAR. ;;; ;;; References: ;;; ;;; [1] Cleve Moler, Matlab News and Notes, Fall 1995. ;;; ;;; [2] F. James, "A Review of Pseudorandom Number Generators", ;;; Computer Physics Communications 60 (1990). ;;; ;;; [3] George Marsaglia, B. Narasimhan, and Arif Zaman, "A Random ;;; Number Generator for PC's", Computer Physics Communications 60 ;;; (1990) 345-349. ;;; According to Marsaglia, a suitable constant is any integer ;;; relatively prime to 2^53. We randomly selected 7097293079245107. ;;; (defconstant weyl-constant #.(scale-float (float 7097293079245107 1d0) -53)) (declaim (ftype (function (random-state) (double-float 0.0d0 (1.0d0))) new-random-float)) (declaim (inline new-random-float)) (defun new-random-float (state) (declare (type random-state state)) (let* ((z (random-state-cache state)) (index (random-state-index state)) (new-z (- (aref z (logand (+ index 20) #x1f)) (aref z (logand (+ index 5) #x1f)) (random-state-borrow state)))) (declare (double-float new-z) (type (simple-array double-float (32)) z) (type (mod 32) index)) ;; Do the subtract-with-borrow generator (setf (random-state-borrow state) (cond ((minusp new-z) (incf new-z 1.0d0) double-float-epsilon) (t 0d0))) (setf (aref z index) new-z) (setf (random-state-index state) (logand (1+ index) #x1f)) ;; Weyl generator (let ((w (- (random-state-weyl state) weyl-constant))) (declare (double-float w)) (let ((w1 (if (minusp w) (1+ w) w))) (declare (double-float w1)) (setf (random-state-weyl state) w1) ;; Mix them together (decf new-z w1) (when (minusp new-z) (incf new-z 1d0)) new-z)))) ;;; %RANDOM-SINGLE-FLOAT, %RANDOM-DOUBLE-FLOAT -- Interface ;;; ;;; Handle the single or double float case of RANDOM. These ;;; functions are required because the compiler will optimize calls ;;; to random to one of the following functions if possible. ;;; (declaim (inline %random-single-float %random-double-float)) (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) (type random-state state)) (* arg (new-random-float state))) (defun %random-single-float (arg state) (declare (type (single-float (0f0)) arg) (type random-state state)) (coerce (%random-double-float (coerce arg 'double-float) state) 'single-float)) ;;;; Random integers: ;;; Random integers are created by concatenating a bunch of chunks ;;; together. Chunks are generated without consing by truncating a ;;; random float to an integer. With the latest propagate-float-type ;;; code the compiler can inline truncate (signed-byte 32) allowing 31 ;;; bits, and (unsigned-byte 32) 32 bits on the x86. When not using the ;;; propagate-float-type feature the best size that can be inlined is ;;; 29 bits. Use of sizes greater than 29 bits causes consing in ;;; argument passing to generic functions, so 29 bits is a good ;;; default. ;;; (defconstant random-chunk-size 29) ;;; %RANDOM-INTEGER -- Internal ;;; ;;; Make a random integer. We extract the most significant bits from ;;; the generator and concatenate enough of them together to make up ;;; the desired integer. (defun %random-integer (arg state) (declare (type (integer 1) arg) (type random-state state)) (flet ((random-chunk (state) (values (truncate (* (float (expt 2 random-chunk-size) 1d0) (new-random-float state)))))) (let ((shift random-chunk-size)) (do ((bits (random-chunk state) (logxor (ash bits shift) (random-chunk state))) (count (+ (integer-length arg) (- 0 shift)) (- count shift))) ((minusp count) (rem bits arg)) (declare (fixnum count)))))) (defun random (arg &optional (state *random-state*)) "Generate a uniformly distributed pseudo-random number between zero and Arg. State, if supplied, is the random state to use." (declare (inline %random-single-float %random-double-float)) (cond ((<= arg 0) (error 'simple-type-error :expected-type '(or (integer 1) (float (0))) :datum arg :format-control "Argument is not a positive integer or a positive float: ~S" :format-arguments (list arg))) ((typep arg 'fixnum) (values (truncate (%random-double-float (coerce arg 'double-float) state)))) ((typep arg 'single-float) (%random-single-float arg state)) ((typep arg 'double-float) (%random-double-float arg state)) ((integerp arg) (%random-integer arg state)) (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0))) :datum arg :format-control "Argument is not a positive integer or a positive float: ~S" :format-arguments (list arg))))) ) ; end progn cmucl-21a/src/code/reader.lisp000066400000000000000000002173401260377556400164240ustar00rootroot00000000000000;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: src/code/reader.lisp $") ;;; ;;; ********************************************************************** ;;; ;;; Spice Lisp Reader ;;; Written by David Dill ;;; Package system interface by Lee Schumacher. ;;; Runs in the standard Spice Lisp environment. ;;; (in-package "EXTENSIONS") (intl:textdomain "cmucl") (export '*ignore-extra-close-parentheses*) (in-package "LISP") (export '(readtable readtable-case readtablep *read-base* *readtable* copy-readtable set-syntax-from-char set-macro-character get-macro-character make-dispatch-macro-character set-dispatch-macro-character get-dispatch-macro-character read *read-default-float-format* read-preserving-whitespace read-delimited-list parse-integer read-from-string *read-suppress* reader-error)) ;;;Random global variables (defvar *read-default-float-format* 'single-float "Float format for 1.0E1") (declaim (type (member short-float single-float double-float long-float) *read-default-float-format*)) (defvar *readtable*) (declaim (type readtable *readtable*)) (setf (documentation '*readtable* 'variable) _N"Variable bound to current readtable.") ;;;; Reader errors: (define-condition reader-error (parse-error stream-error) ((format-control :reader reader-error-format-control :initarg :format-control) (format-arguments :reader reader-error-format-arguments :initarg :format-arguments :initform '())) (:report (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) (when c:*compiler-notification-function* (funcall c:*compiler-notification-function* :error (apply #'format nil (reader-error-format-control condition) (reader-error-format-arguments condition)) nil error-stream (file-position error-stream))) (format stream (intl:gettext "Reader error ~@[at ~D ~]on ~S:~%~?") (and (open-stream-p error-stream) (file-position error-stream)) error-stream (reader-error-format-control condition) (reader-error-format-arguments condition)))))) (define-condition reader-package-error (reader-error) ()) ;;; %READ-ERROR -- Interface ;;; ;;; Like, signal a READ-ERROR, man... ;;; (defun %reader-error (stream control &rest args) (error 'reader-error :stream stream :format-control control :format-arguments args)) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) (:report (lambda (condition stream) (format stream (intl:gettext "Unexpected EOF on ~S ~A.") (stream-error-stream condition) (reader-eof-error-context condition))))) (defun reader-eof-error (stream context) (error 'reader-eof-error :stream stream :context context)) ;;;; Readtable implementation. (defvar std-lisp-readtable () "Standard lisp readtable. This is for recovery from broken read-tables, and should not normally be user-visible.") ;; Max size of the attribute table before we switch from an array to a ;; hash-table. (defconstant attribute-table-limit #-unicode char-code-limit #+unicode 256) (deftype attribute-table () '(simple-array (unsigned-byte 8) (#.attribute-table-limit))) (defstruct (readtable (:conc-name nil) (:predicate readtablep) (:copier nil) (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t) (prin1 'readtable stream))))) "Readtable is a data structure that maps characters into syntax types for the Common Lisp expression reader." ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of ATTRIBUTE-TABLE-LIMIT integers for ;; describing the character type. Conceptually, there are 4 distinct ;; "primary" character attributes: WHITESPACE, TERMINATING-MACRO, ESCAPE, and ;; CONSTITUENT. Non-terminating macros (such as the symbol reader) have the ;; attribute CONSTITUENT. ;; ;; In order to make the READ-TOKEN fast, all this information is ;; stored in the character attribute table by having different varieties of ;; constituents. (character-attribute-table (make-array attribute-table-limit :element-type '(unsigned-byte 8) :initial-element constituent) :type attribute-table) ;; ;; The CHARACTER-MACRO-TABLE is a vector of ATTRIBUTE-TABLE-LIMIT functions. One ;; of these functions called with appropriate arguments whenever any ;; non-WHITESPACE character is encountered inside READ-PRESERVING-WHITESPACE. ;; These functions are used to implement user-defined read-macros, system ;; read-macros, and the number-symbol reader. (character-macro-table (make-array attribute-table-limit :initial-element #'undefined-macro-char) :type (simple-vector #.attribute-table-limit)) ;; ;; DISPATCH-TABLES entry, which is an alist from dispatch characters to ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching ;; macros (like #-macro). (dispatch-tables () :type list) (%readtable-case :upcase :type (member :upcase :downcase :preserve :invert)) ;; ;; The CHARACTER-ATTRIBUTE-HASH-TABLE handles the case of char codes ;; above ATTRIBUTE-TABLE-LIMIT, since we expect these to be ;; relatively rare. #+unicode (character-attribute-hash-table (make-hash-table) :type (or null hash-table)) ;; ;; The CHARACTER-MACRO-HASH-TABLE handles the case of char codes ;; above ATTRIBUTE-TABLE-LIMIT, since we expect these to be ;; relatively rare. #+unicode (character-macro-hash-table (make-hash-table) :type (or null hash-table))) ;;;; Constants for character attributes. These are all as in the manual. (eval-when (compile load eval) (defconstant whitespace 0) (defconstant terminating-macro 1) (defconstant escape 2) (defconstant constituent 3) (defconstant constituent-dot 4) (defconstant constituent-expt 5) (defconstant constituent-slash 6) (defconstant constituent-digit 7) (defconstant constituent-sign 8) ; 9 (defconstant multiple-escape 10) (defconstant package-delimiter 11) ;;fake attribute for use in read-unqualified-token (defconstant delimiter 12) ;; More fake attributes for used for reading numbers. ;; ;; The following two are not static but depend on *READ-BASE*. ;; DECIMAL-DIGIT is for characters being digits in base 10 but not in ;; base *READ-BASE* (which is therefore perforce smaller than 10); ;; DIGIT-OR-EXPT is for characters being both exponent markers and ;; digits in base *READ-BASE* (which is therefore perforce larger ;; than 10). (defconstant constituent-decimal-digit 13) (defconstant constituent-digit-or-expt 14) ;; Invalid constituent character (defconstant constituent-invalid 15)) ;;;; Package specials. (defvar *old-package* () "Value of *package* at the start of the last read or Nil.") ;;; In case we get an error trying to parse a symbol, we want to rebind the ;;; above stuff so it's cool. (declaim (special *package* *keyword-package* *read-base*)) ;;;; Macros and functions for character tables. #-unicode (defmacro get-cat-entry (char rt) ;;only give this side-effect-free args. `(elt (character-attribute-table ,rt) (char-code ,char))) #+unicode (defmacro get-cat-entry (char rt) ;;only give this side-effect-free args. `(if (< (char-code ,char) attribute-table-limit) (elt (character-attribute-table ,rt) (char-code ,char)) (gethash (char-code ,char) (character-attribute-hash-table ,rt) ;; Default is constituent, because the attribute table ;; is initialized to constituent constituent))) #-unicode (defun set-cat-entry (char newvalue &optional (rt *readtable*)) (setf (elt (character-attribute-table rt) (char-code char)) newvalue)) #+unicode (defun set-cat-entry (char newvalue &optional (rt *readtable*)) (let ((code (char-code char))) (if (< code attribute-table-limit) (setf (elt (character-attribute-table rt) code) newvalue) (unless (= newvalue constituent) ;; The default value (in get-cat-entry) is constituent, so ;; don't enter it into the hash table. (setf (gethash code (character-attribute-hash-table rt)) newvalue))))) #-unicode (defmacro get-cmt-entry (char rt) `(the function (elt (the simple-vector (character-macro-table ,rt)) (char-code ,char)))) #+unicode (defmacro get-cmt-entry (char rt) `(if (< (char-code ,char) attribute-table-limit) (the function (elt (the simple-vector (character-macro-table ,rt)) (char-code ,char))) (gethash (char-code ,char) (character-macro-hash-table ,rt) ;; This default value needs to be coordinated with ;; init-std-lisp-readtable. #'read-token))) #-unicode (defun set-cmt-entry (char newvalue &optional (rt *readtable*)) (setf (elt (the simple-vector (character-macro-table rt)) (char-code char)) (coerce newvalue 'function))) #+unicode (defun set-cmt-entry (char newvalue &optional (rt *readtable*)) (let ((code (char-code char))) (if (< code attribute-table-limit) (setf (elt (the simple-vector (character-macro-table rt)) code) (coerce newvalue 'function)) (let ((f (coerce newvalue 'function))) ;; Don't add an entry if the function would be the same as ;; the default. This needs to be coordinated with ;; GET-CMT-ENTRY above. (if (eq f #'read-token) f (setf (gethash code (character-macro-hash-table rt)) f)))))) (defun undefined-macro-char (stream char) (unless *read-suppress* (%reader-error stream (intl:gettext "Undefined read-macro character ~S") char))) ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers. (defmacro test-attribute (char whichclass rt) `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass)) ;;; Predicates for testing character attributes ;;; Make this a function, since other people want to use it. ;;; (declaim (inline whitespacep)) (defun whitespacep (char &optional (rt *readtable*)) (test-attribute char whitespace rt)) (defmacro constituentp (char &optional (rt '*readtable*)) `(test-attribute ,char #.constituent ,rt)) (defmacro terminating-macrop (char &optional (rt '*readtable*)) `(test-attribute ,char #.terminating-macro ,rt)) (defmacro escapep (char &optional (rt '*readtable*)) `(test-attribute ,char #.escape ,rt)) (defmacro multiple-escape-p (char &optional (rt '*readtable*)) `(test-attribute ,char #.multiple-escape ,rt)) (defmacro token-delimiterp (char &optional (rt '*readtable*)) ;;depends on actual attribute numbering above. `(<= (get-cat-entry ,char ,rt) #.terminating-macro)) ;;;; Secondary attribute table. ;;; There are a number of "secondary" attributes which are constant properties ;;; of characters characters (as long as they are constituents). (defvar secondary-attribute-table) (declaim (type attribute-table secondary-attribute-table)) (defun set-secondary-attribute (char attribute) (setf (elt secondary-attribute-table (char-code char)) attribute)) (defun init-secondary-attribute-table () (setq secondary-attribute-table (make-array attribute-table-limit :element-type '(unsigned-byte 8) :initial-element #.constituent)) (set-secondary-attribute #\: #.package-delimiter) ;;(set-secondary-attribute #\| #.multiple-escape) ; |) [For EMACS] (set-secondary-attribute #\. #.constituent-dot) (set-secondary-attribute #\+ #.constituent-sign) (set-secondary-attribute #\- #.constituent-sign) (set-secondary-attribute #\/ #.constituent-slash) (do ((i (char-code #\0) (1+ i))) ((> i (char-code #\9))) (set-secondary-attribute (code-char i) #.constituent-digit)) (set-secondary-attribute #\E #.constituent-expt) (set-secondary-attribute #\F #.constituent-expt) (set-secondary-attribute #\D #.constituent-expt) (set-secondary-attribute #\S #.constituent-expt) (set-secondary-attribute #\L #.constituent-expt) (set-secondary-attribute #\e #.constituent-expt) (set-secondary-attribute #\f #.constituent-expt) (set-secondary-attribute #\d #.constituent-expt) (set-secondary-attribute #\s #.constituent-expt) (set-secondary-attribute #\l #.constituent-expt) #+double-double (progn (set-secondary-attribute #\W #.constituent-expt) (set-secondary-attribute #\w #.constituent-expt)) ;; See CLHS 2.1.4.2 for the list of constituent characters that are ;; invalid constituent characters. (set-secondary-attribute #\Space #.constituent-invalid) (set-secondary-attribute #\Newline #.constituent-invalid) (dolist (c '(#\backspace #\tab #\page #\return #\rubout)) (set-secondary-attribute c #.constituent-invalid))) #-unicode (defmacro get-secondary-attribute (char) `(elt secondary-attribute-table (char-code ,char))) #+unicode (defmacro get-secondary-attribute (char) `(if (< (char-code ,char) attribute-table-limit) (elt secondary-attribute-table (char-code ,char)) constituent)) ;;; Character dispatch stuff ;; For non-unicode stuff, a simple vector of 256 elements works fine. #-unicode (defun make-char-dispatch-table () (make-array attribute-table-limit :initial-element #'dispatch-char-error)) #-unicode (declaim (inline copy-char-dispatch-table)) #-unicode (defun copy-char-dispatch-table (dispatch) (copy-seq dispatch)) ;; For unicode, we define a structure to hold a vector and a ;; hash-table to conserve space instead of using a huge vector. The ;; vector handles the common case for 8-bit characters, and the hash ;; table handles the rest. #+unicode (defstruct (char-dispatch-table (:copier nil) (:print-function (lambda (s stream d) (declare (ignore d)) (print-unreadable-object (s stream :identity t :type t) )))) ;; TABLE is a vector for quick access for 8-bit characters (table (make-array attribute-table-limit :initial-element #'dispatch-char-error) :type (simple-vector #.attribute-table-limit)) ;; HASH-TABLE is for handling the (presumably) rare case of dispatch ;; characters above attribute-table-limit. (hash-table (make-hash-table) :type hash-table)) #+unicode (defun copy-char-dispatch-table (dispatch) ;; Make a new dispatch table and copy the contents to it (let* ((new (make-char-dispatch-table)) (h (char-dispatch-table-hash-table new))) (replace (char-dispatch-table-table new) (char-dispatch-table-table dispatch)) (maphash #'(lambda (key val) (setf (gethash key h) val)) (char-dispatch-table-hash-table dispatch)) new)) (declaim (inline get-dispatch-char set-dispatch-char)) #-unicode (defun get-dispatch-char (char dispatch) (elt (the simple-vector dispatch) (char-code char))) #+unicode (defun get-dispatch-char (char dispatch) (let ((code (char-code char))) (if (< code attribute-table-limit) (elt (the simple-vector (char-dispatch-table-table dispatch)) code) (gethash char (char-dispatch-table-hash-table dispatch) #'dispatch-char-error)))) #-unicode (defun set-dispatch-char (char new-value dispatch) (setf (elt (the simple-vector dispatch) (char-code char)) (coerce new-value 'function))) #+unicode (defun set-dispatch-char (char new-value dispatch) (let ((code (char-code char))) (if (< code attribute-table-limit) (setf (elt (the simple-vector (char-dispatch-table-table dispatch)) (char-code char)) (coerce new-value 'function)) (setf (gethash char (char-dispatch-table-hash-table dispatch)) (coerce new-value 'function))))) ;;;; Readtable operations. (defun assert-not-standard-readtable (readtable operation) (when (eq readtable std-lisp-readtable) (cerror "Modify it anyway." 'kernel:standard-readtable-modified-error :operation operation))) (defun readtable-case (table) (%readtable-case table)) (defun (setf readtable-case) (new-case table) (assert-not-standard-readtable table '(setf readtable-case)) (setf (%readtable-case table) new-case)) (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) "A copy is made of from-readtable and place into to-readtable." (assert-not-standard-readtable to-readtable 'copy-readtable) (let ((from-readtable (or from-readtable std-lisp-readtable)) (to-readtable (or to-readtable (make-readtable)))) (flet ((copy-hash-table (to from) (clrhash to) (maphash #'(lambda (key val) (setf (gethash key to) val)) from))) ;;physically clobber contents of internal tables. (replace (character-attribute-table to-readtable) (character-attribute-table from-readtable)) (replace (character-macro-table to-readtable) (character-macro-table from-readtable)) #+unicode (progn (copy-hash-table (character-attribute-hash-table to-readtable) (character-attribute-hash-table from-readtable)) (copy-hash-table (character-macro-hash-table to-readtable) (character-macro-hash-table from-readtable))) (setf (dispatch-tables to-readtable) (mapcar #'(lambda (pair) (cons (car pair) (copy-char-dispatch-table (cdr pair)))) (dispatch-tables from-readtable))) (setf (readtable-case to-readtable) (readtable-case from-readtable)) to-readtable))) (defun set-syntax-from-char (to-char from-char &optional (to-readtable *readtable*) (from-readtable ())) "Causes the syntax of to-char to be the same as from-char in the optional readtable (defaults to the current readtable). The from-table defaults the standard lisp readtable by being nil." (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (let ((from-readtable (or from-readtable std-lisp-readtable))) ;;copy from-char entries to to-char entries, but make sure that if ;;from char is a constituent you don't copy non-movable secondary ;;attributes (constituent types), and that said attributes magically ;;appear if you transform a non-constituent to a constituent. (let ((att (get-cat-entry from-char from-readtable)) (mac (get-cmt-entry from-char from-readtable)) (from-dpair (find from-char (dispatch-tables from-readtable) :test #'char= :key #'car)) (to-dpair (find to-char (dispatch-tables to-readtable) :test #'char= :key #'car))) #+nil (if (constituentp from-char from-readtable) (setq att (get-secondary-attribute to-char))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char mac to-readtable) ;; Copy the reader macro functions too if from-char is a ;; dispatching macro character. ;;(format t "from-dpair = ~A~%" from-dpair) (when from-dpair (cond (to-dpair ;; The to-readtable already has a dispatching table for ;; this character. Replace it with a copy of the ;; dispatching table from from-readtable. (setf (cdr to-dpair) (copy-char-dispatch-table (cdr from-dpair)))) (t ;; The to-readtable doesn't have such an entry. Add a ;; copy of dispatch table from from-readtable to the ;; dispatch table of the to-readtable. (let ((pair (cons to-char (copy-char-dispatch-table (cdr from-dpair))))) (setf (dispatch-tables to-readtable) (push pair (dispatch-tables to-readtable))))))))) t) (defun set-macro-character (char function &optional (non-terminatingp nil) (rt *readtable*)) "Causes char to be a macro character which invokes function when seen by the reader. The non-terminatingp flag can be used to make the macro character non-terminating. The optional readtable argument defaults to the current readtable. Set-macro-character returns T." (let ((designated-readtable (or rt std-lisp-readtable))) (assert-not-standard-readtable designated-readtable 'set-macro-character) (if non-terminatingp (set-cat-entry char (get-secondary-attribute char) designated-readtable) (set-cat-entry char #.terminating-macro designated-readtable)) (set-cmt-entry char function designated-readtable)) T) (defun get-macro-character (char &optional (rt *readtable*)) "Returns the function associated with the specified char which is a macro character. The optional readtable argument defaults to the current readtable." (let ((rt (or rt std-lisp-readtable))) ;; Check macro syntax, return associated function if it's there. ;; Returns a value for all constituents. (cond ((constituentp char rt) (values (get-cmt-entry char rt) t)) ((terminating-macrop char rt) (values (get-cmt-entry char rt) nil)) (t nil)))) ;;;; These definitions support internal programming conventions. (defconstant eof-object '(*eof*)) (defmacro eofp (char) `(eq ,char eof-object)) (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) (stream-dispatch stream ;; simple-stream (do ((char (stream::%read-char stream t nil t t) (stream::%read-char stream t nil t t))) ((not (test-attribute char #.whitespace *readtable*)) char)) ;; lisp-stream (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((not (test-attribute char #.whitespace *readtable*)) (done-with-fast-read-char) char))) ;; fundamental-stream (do ((char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof) (not (test-attribute char #.whitespace *readtable*))) (if (eq char :eof) (error 'end-of-file :stream stream) char)))))) ;;;; Temporary initialization hack. (defun init-std-lisp-readtable () (setq std-lisp-readtable (make-readtable)) ;;all characters default to "constituent" in make-readtable ;;*** un-constituent-ize some of these *** (handler-bind ((standard-readtable-modified-error (lambda (c) (declare (ignore c)) ;; Of course, we want to be able to modify the standard ;; readtable here! (invoke-restart 'kernel::continue)))) (let ((*readtable* std-lisp-readtable) (*assert-not-standard-readtable* nil)) (set-cat-entry #\tab #.whitespace) (set-cat-entry #\linefeed #.whitespace) (set-cat-entry #\space #.whitespace) (set-cat-entry #\page #.whitespace) (set-cat-entry #\return #.whitespace) (set-cat-entry #\\ #.escape) (set-cat-entry #\| #.multiple-escape) (set-cmt-entry #\\ #'read-token) (set-cmt-entry #\: #'read-token) (set-cmt-entry #\| #'read-token) ;;macro definitions (set-macro-character #\" #'read-string) ;;* # macro (set-macro-character #\' #'read-quote) (set-macro-character #\( #'read-list) (set-macro-character #\) #'read-right-paren) (set-macro-character #\; #'read-comment) ;;* backquote ;;all constituents (do ((ichar 0 (1+ ichar)) (len #+unicode-bootstrap #o200 #-unicode-bootstrap char-code-limit)) ((= ichar len)) (let ((char (code-char ichar))) #-unicode (when (constituentp char std-lisp-readtable) (set-cat-entry char (get-secondary-attribute char)) (set-cmt-entry char #'read-token)) #+unicode (cond ((constituentp char std-lisp-readtable) (set-cat-entry char (get-secondary-attribute char)) (when (< ichar attribute-table-limit) ;; The hashtable default in get-cmt-entry returns ;; #'read-token, so don't need to set it here. (set-cmt-entry char #'read-token))) ((>= ichar attribute-table-limit) ;; A non-constituent character that would be stored in ;; the hash table gets #'undefined-macro-char. (set-cmt-entry char #'undefined-macro-char)))))))) ;;;; read-buffer implementation. (defvar *read-buffer*) (defvar *read-buffer-length*) (defvar *inch-ptr*) (defvar *ouch-ptr*) (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*)) (declaim (simple-string *read-buffer*)) (defconstant +read-buffer-pool-size+ 16) (defconstant +read-buffer-initial-size+ 16) (defun make-read-buffer-stack (size count) (let ((stack (make-array count :fill-pointer 0))) (dotimes (i count) (vector-push (make-string size) stack)) stack)) (defvar *read-buffer-stack*) (defun init-read-buffer-stack () (setq *read-buffer-stack* (make-read-buffer-stack +read-buffer-initial-size+ +read-buffer-pool-size+))) (defun allocate-read-buffer () (cond ((zerop (fill-pointer *read-buffer-stack*)) (make-string 32)) (t (vector-pop *read-buffer-stack*)))) (defun free-read-buffer (buffer) (vector-push buffer *read-buffer-stack*)) ;;; Recursive reader functions use with-read-buffer to allocate a ;;; fresh buffer. We currently allocate a fresh buffer only for the ;;; exported functions READ, READ-PRESERVING-WHITESPACE, ;;; READ-FROM-STRING, and READ-DELIMITED-LIST. Some internal ;;; functions like READ-TOKEN, INTERNAL-READ-EXTENDED-TOKEN and ;;; READ-STRING avoid the overhead for the allocation and clobber the ;;; current read-buffer. (defmacro with-read-buffer (() &body body) "Bind *read-buffer* to a fresh buffer and execute Body." `(let* ((*read-buffer* (allocate-read-buffer)) (*read-buffer-length* (length *read-buffer*)) (*ouch-ptr* 0) (*inch-ptr* 0)) (unwind-protect (progn ,@body) (free-read-buffer *read-buffer*)))) (defmacro reset-read-buffer () ;;turn *read-buffer* into an empty read-buffer. ;;*ouch-ptr* always points to next char to write `(progn (setq *ouch-ptr* 0) ;;*inch-ptr* always points to next char to read (setq *inch-ptr* 0))) (defmacro ouch-read-buffer (char) `(progn (if (>= (the fixnum *ouch-ptr*) (the fixnum *read-buffer-length*)) ;;buffer overflow -- double the size (grow-read-buffer)) (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char) (setq *ouch-ptr* (1+ *ouch-ptr*)))) ;; macro to move *ouch-ptr* back one. (defmacro ouch-unread-buffer () '(if (> (the fixnum *ouch-ptr*) (the fixnum *inch-ptr*)) (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*))))) (defun grow-read-buffer () (let ((rbl (length (the simple-string *read-buffer*)))) (declare (fixnum rbl)) (setq *read-buffer* (concatenate 'simple-string (the simple-string *read-buffer*) (the simple-string (make-string rbl)))) (setq *read-buffer-length* (* 2 rbl)))) (defun inchpeek-read-buffer () (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*)) eof-object (elt (the simple-string *read-buffer*) *inch-ptr*))) (defun inch-read-buffer () (cond ((>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*)) eof-object) (t (prog1 (elt (the simple-string *read-buffer*) *inch-ptr*) (setq *inch-ptr* (1+ (the fixnum *inch-ptr*))))))) (defmacro unread-buffer () `(decf (the fixnum *inch-ptr*))) (defun read-unwind-read-buffer () ;;keep contents, but make next (inch..) return first char. (setq *inch-ptr* 0)) (defun read-buffer-to-string () (subseq (the simple-string *read-buffer*) 0 *ouch-ptr*)) ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ. (defvar *ignore-extra-close-parentheses* t "If true, only warn when there is an extra close paren, otherwise error.") (declaim (special *standard-input*)) ;;; The SHARP-EQUAL function introduces a label for an object, and the ;;; SHARP-SHARP function allows us to refer to this label. This is slightly ;;; tricky because the object we are labelling can contain labels to itself in ;;; order to create circular structures, e.g., #1=(cons 'hello #1#). ;;; ;;; The SHARP-EQUAL function is called when we are reading a stream and ;;; encounter text of the form #